libguile/fports.c

   1 /*      Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45
  46 #include "fports.h"
  47
  48 #ifdef HAVE_STRING_H
  49 #include <string.h>
  50 #endif
  51 #ifdef HAVE_UNISTD_H
  52 #include <unistd.h>
  53 #else
  54 scm_sizet fwrite ();
  55 #endif
  56
  57 \f
  58 /* Port direction --- handling el cheapo stdio implementations.
  59
  60    Guile says that when you've got a port that's both readable and
  61    writable, like a socket, why then, by gum, you can read from it and
  62    write to it!  However, most standard I/O implementations make
  63    cheezy caveats like this:
  64
  65         When a file is opened for update, both input and output  may
  66         be done on the resulting stream.  However, output may not be
  67         directly followed by input without an intervening  fflush(),
  68         fseek(),  fsetpos(),  or  rewind(),  and  input  may  not be
  69         directly followed by output without an intervening  fseek(),
  70         fsetpos(),   or   rewind(),   or  an  input  operation  that
  71         encounters end-of-file.
  72                    -- the Solaris fdopen(3S) man page
  73
  74    I think this behavior is permitted by the ANSI C standard.
  75
  76    So we made the implementation more complex, so what the user sees
  77    remains simple.  When we have a Guile port based on a stdio stream
  78    (this source file's specialty), we keep track of whether it was
  79    last written to, read from, or whether it is in a safe state for
  80    both operations.  Each port operation function just checks the
  81    state of the port before each operation, and does the required
  82    magic if necessary.
  83
  84    We use two bits in the CAR of the port, FPORT_READ_SAFE and
  85    FPORT_WRITE_SAFE, to indicate what operations the underlying stdio
  86    stream could correctly perform next.  You're not allowed to clear
  87    them both at the same time, but both can be set --- for example, if
  88    the stream has just been opened, or flushed, or had its position
  89    changed.
  90
  91    It's possible for a port to have neither bit set, if we receive a
  92    FILE * pointer in an unknown state; this code should handle that
  93    gracefully.  */
  94
  95 #define FPORT_READ_SAFE  (1L << 24)
  96 #define FPORT_WRITE_SAFE (2L << 24)
  97
  98 #define FPORT_ALL_OKAY(port) \
  99      (SCM_SETOR_CAR (port, (FPORT_READ_SAFE | FPORT_WRITE_SAFE)))
 100
 101 static inline void
 102 pre_read (SCM port)
 103 {
 104   if (! (SCM_CAR (port) & FPORT_READ_SAFE))
 105     fflush ((FILE *)SCM_STREAM (port));
 106
 107   /* We've done the flush, so reading is safe.
 108      Assuming that we're going to do a read next, writing will not be
 109      safe by the time we're done.  */
 110   SCM_SETOR_CAR  (port,  FPORT_READ_SAFE);
 111   SCM_SETAND_CAR (port, ~FPORT_WRITE_SAFE);
 112
 113 }
 114
 115 static inline void
 116 pre_write (SCM port)
 117 {
 118   if (! (SCM_CAR (port) & FPORT_WRITE_SAFE))
 119     /* This can fail, if we're talking to a line-buffered terminal.  As
 120        far as I can tell, there's no way to get mixed reads and writes
 121        to work on a line-buffered terminal at all --- you get a full
 122        line in the buffer when you read, and then you have to throw it
 123        out to write.  You have to do unbuffered input, and make the
 124        system provide the second buffer.  */
 125     fseek ((FILE *)SCM_STREAM (port), 0, SEEK_CUR);
 126
 127   /* We've done the seek, so writing is safe.
 128      Assuming that we're going to do a write next, reading will not be
 129      safe by the time we're done.  */
 130   SCM_SETOR_CAR (port, FPORT_WRITE_SAFE);
 131   SCM_SETAND_CAR (port, ~FPORT_READ_SAFE);
 132 }
 133
 134 \f
 135 /* Helpful operations on stdio FILE-based ports  */
 136
 137 /* should be called with SCM_DEFER_INTS active */
 138
 139 SCM
 140 scm_setbuf0 (port)
 141      SCM port;
 142 {
 143   /* NOSETBUF was provided by scm to allow unbuffered ports to be
 144      avoided on systems where ungetc didn't work correctly.  See
 145      comment in unif.c, which seems to be the only place where it
 146      could still be a problem.  */
 147 #ifndef NOSETBUF
 148   /*  SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0);); */
 149   SCM_SYSCALL (setvbuf ((FILE *)SCM_STREAM (port), 0, _IONBF, 0););
 150 #endif
 151   return SCM_UNSPECIFIED;
 152 }
 153
 154 SCM_PROC (s_setvbuf, "setvbuf", 2, 1, 0, scm_setvbuf);
 155 SCM
 156 scm_setvbuf (SCM port, SCM mode, SCM size)
 157 {
 158   int rv;
 159   int cmode, csize;
 160
 161   port = SCM_COERCE_OUTPORT (port);
 162
 163   SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG1, s_setvbuf);
 164   SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_setvbuf);
 165   if (SCM_UNBNDP (size))
 166     csize = 0;
 167   else
 168     {
 169       SCM_ASSERT (SCM_INUMP (size), size, SCM_ARG3, s_setvbuf);
 170       csize = SCM_INUM (size);
 171     }
 172   cmode = SCM_INUM (mode);
 173   if (csize == 0 && cmode == _IOFBF)
 174     cmode = _IONBF;
 175   SCM_DEFER_INTS;
 176   SCM_SYSCALL (rv = setvbuf ((FILE *)SCM_STREAM (port), 0, cmode, csize));
 177   if (rv < 0)
 178     scm_syserror (s_setvbuf);
 179   if (cmode == _IONBF)
 180     SCM_SETCAR (port, SCM_CAR (port) | SCM_BUF0);
 181   else
 182     SCM_SETCAR (port, (SCM_CAR (port) & ~SCM_BUF0));
 183   SCM_ALLOW_INTS;
 184   return SCM_UNSPECIFIED;
 185 }
 186
 187 #ifdef FD_SETTER
 188 #define SET_FILE_FD_FIELD(F,D) ((F)->FD_SETTER = (D))
 189 #endif
 190
 191 void
 192 scm_setfileno (fs, fd)
 193      FILE *fs;
 194      int fd;
 195 {
 196 #ifdef SET_FILE_FD_FIELD
 197   SET_FILE_FD_FIELD(fs, fd);
 198 #else
 199   scm_misc_error ("scm_setfileno", "Not fully implemented on this platform",
 200                   SCM_EOL);
 201 #endif
 202 }
 203
 204 /* Move ports with the specified file descriptor to new descriptors,
 205  * reseting the revealed count to 0.
 206  * Should be called with SCM_DEFER_INTS active.
 207  */
 208
 209 void
 210 scm_evict_ports (fd)
 211      int fd;
 212 {
 213   int i;
 214
 215   for (i = 0; i < scm_port_table_size; i++)
 216     {
 217       if (SCM_FPORTP (scm_port_table[i]->port)
 218           && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd)
 219         {
 220           scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd));
 221           scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0));
 222         }
 223     }
 224 }
 225
 226 /* scm_open_file
 227  * Return a new port open on a given file.
 228  *
 229  * The mode string must match the pattern: [rwa+]** which
 230  * is interpreted in the usual unix way.
 231  *
 232  * Return the new port.
 233  */
 234 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 235
 236 SCM
 237 scm_open_file (filename, modes)
 238      SCM filename;
 239      SCM modes;
 240 {
 241   SCM port;
 242   FILE *f;
 243   char *file;
 244   char *mode;
 245
 246   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 247   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 248   if (SCM_SUBSTRP (filename))
 249     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 250   if (SCM_SUBSTRP (modes))
 251     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 252
 253   file = SCM_ROCHARS (filename);
 254   mode = SCM_ROCHARS (modes);
 255
 256   SCM_DEFER_INTS;
 257   SCM_SYSCALL (f = fopen (file, mode));
 258   if (!f)
 259     {
 260       int en = errno;
 261
 262       scm_syserror_msg (s_open_file, "%s: %S",
 263                         scm_listify (scm_makfrom0str (strerror (errno)),
 264                                      filename,
 265                                      SCM_UNDEFINED),
 266                         en);
 267     }
 268   else
 269     port = scm_stdio_to_port (f, mode, filename);
 270   SCM_ALLOW_INTS;
 271   return port;
 272 }
 273
 274
 275 SCM_PROC (s_freopen, "freopen", 3, 0, 0, scm_freopen);
 276
 277 SCM
 278 scm_freopen (filename, modes, port)
 279      SCM filename;
 280      SCM modes;
 281      SCM port;
 282 {
 283   FILE *f;
 284   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 285               SCM_ARG1, s_freopen);
 286   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
 287               s_freopen);
 288
 289   SCM_COERCE_SUBSTR (filename);
 290   SCM_COERCE_SUBSTR (modes);
 291   port = SCM_COERCE_OUTPORT (port);
 292   SCM_DEFER_INTS;
 293   SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_freopen);
 294   SCM_SYSCALL (f = freopen (SCM_ROCHARS (filename), SCM_ROCHARS (modes),
 295                             (FILE *)SCM_STREAM (port)));
 296   if (!f)
 297     {
 298       SCM p;
 299       p = port;
 300       port = SCM_MAKINUM (errno);
 301       SCM_SETAND_CAR (p, ~SCM_OPN);
 302       scm_remove_from_port_table (p);
 303     }
 304   else
 305     {
 306       SCM_SETSTREAM (port, (SCM)f);
 307       SCM_SETCAR (port, (scm_tc16_fport
 308                          | scm_mode_bits (SCM_ROCHARS (modes))
 309                          | FPORT_READ_SAFE | FPORT_WRITE_SAFE));
 310       if (SCM_BUF0 & SCM_CAR (port))
 311         scm_setbuf0 (port);
 312     }
 313   SCM_ALLOW_INTS;
 314   return port;
 315 }
 316
 317
 318 \f
 319 /* Building Guile ports from stdio FILE pointers.  */
 320
 321 /* Build a Scheme port from an open stdio port, FILE.
 322    MODE indicates whether FILE is open for reading or writing; it uses
 323       the same notation as open-file's second argument.
 324    Use NAME as the port's filename.  */
 325 SCM
 326 scm_stdio_to_port (FILE *file, char *mode, SCM name)
 327 {
 328   long mode_bits = scm_mode_bits (mode);
 329   SCM port;
 330   struct scm_port_table * pt;
 331
 332   SCM_NEWCELL (port);
 333   SCM_DEFER_INTS;
 334   {
 335     pt = scm_add_to_port_table (port);
 336     SCM_SETPTAB_ENTRY (port, pt);
 337     SCM_SETCAR (port, (scm_tc16_fport
 338                        | mode_bits
 339                        | FPORT_READ_SAFE | FPORT_WRITE_SAFE));
 340     SCM_SETSTREAM (port, (SCM) file);
 341     if (SCM_BUF0 & SCM_CAR (port))
 342       scm_setbuf0 (port);
 343     SCM_PTAB_ENTRY (port)->file_name = name;
 344   }
 345   SCM_ALLOW_INTS;
 346   return port;
 347 }
 348
 349
 350 /* Like scm_stdio_to_port, except that:
 351    - NAME is a standard C string, not a Guile string
 352    - we set the revealed count for FILE's file descriptor to 1, so
 353      that FILE won't be closed when the port object is GC'd.  */
 354 SCM
 355 scm_standard_stream_to_port (FILE *file, char *mode, char *name)
 356 {
 357   SCM port = scm_stdio_to_port (file, mode, scm_makfrom0str (name));
 358   scm_set_port_revealed_x (port, SCM_MAKINUM (1));
 359   return port;
 360 }
 361
 362
 363 \f
 364 /* The fport and pipe port scm_ptobfuns functions --- reading and writing  */
 365
 366 static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 367
 368 static int
 369 prinfport (exp, port, pstate)
 370      SCM exp;
 371      SCM port;
 372      scm_print_state *pstate;
 373 {
 374   SCM name;
 375   char * c;
 376   if (SCM_CLOSEDP (exp))
 377     {
 378       c = "file";
 379     }
 380   else
 381     {
 382       name = SCM_PTAB_ENTRY (exp)->file_name;
 383       if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 384         c = SCM_ROCHARS (name);
 385       else
 386         c = "file";
 387     }
 388
 389   scm_prinport (exp, port, c);
 390   return !0;
 391 }
 392
 393
 394
 395 static int
 396 local_fgetc (SCM port)
 397 {
 398   FILE *s = (FILE *) SCM_STREAM (port);
 399   pre_read (port);
 400   if (feof (s))
 401     return EOF;
 402   else
 403     return fgetc (s);
 404 }
 405
 406
 407 static char *
 408 local_fgets (SCM port, int *len)
 409 {
 410   FILE *f;
 411
 412   char *buf   = NULL;
 413   char *p;              /* pointer to current buffer position */
 414   int   limit = 80;     /* current size of buffer */
 415
 416   pre_read (port);
 417
 418   /* If this is a socket port or something where we can't rely on
 419      ftell to determine how much we've read, then call the generic
 420      function.  We could use a separate scm_ptobfuns table with
 421      scm_generic_fgets, but then we'd have to change SCM_FPORTP, etc.
 422      Ideally, it should become something that means "this port has a
 423      file descriptor"; sometimes we reject sockets when we shouldn't.
 424      But I'm too stupid at the moment to do that right.  */
 425   if (SCM_CAR (port) & SCM_NOFTELL)
 426     return scm_generic_fgets (port, len);
 427
 428   f = (FILE *) SCM_STREAM (port);
 429   if (feof (f))
 430     return NULL;
 431
 432   buf = (char *) malloc (limit * sizeof(char));
 433   *len = 0;
 434
 435   /* If a char has been pushed onto the port with scm_ungetc,
 436      read that first. */
 437   while (SCM_CRDYP (port))
 438     {
 439       buf[*len] = SCM_CGETUN (port);
 440       SCM_TRY_CLRDY (port);
 441       if (buf[(*len)++] == '\n' || *len == limit - 1)
 442         {
 443           buf[*len] = '\0';
 444           return buf;
 445         }
 446     }
 447
 448   while (1)
 449     {
 450       int chunk_size = limit - *len;
 451       long int numread, pos;
 452
 453       p = buf + *len;
 454
 455       /* We must use ftell to figure out how many characters were read.
 456          If there are null characters near the end of file, and no
 457          terminating newline, there is no other way to tell the difference
 458          between an embedded null and the string-terminating null. */
 459
 460       pos = ftell (f);
 461       if (fgets (p, chunk_size, f) == NULL) {
 462         if (*len)
 463           return buf;
 464         free (buf);
 465         return NULL;
 466       }
 467       numread = ftell (f) - pos;
 468       *len += numread;
 469
 470       if (numread < chunk_size - 1 || buf[limit-2] == '\n')
 471         return buf;
 472
 473       buf = (char *) realloc (buf, sizeof(char) * limit * 2);
 474       limit *= 2;
 475     }
 476 }
 477
 478 #ifdef vms
 479
 480 static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
 481
 482 static scm_sizet
 483 pwrite (ptr, size, nitems, port)
 484      char *ptr;
 485      scm_sizet size, nitems;
 486      FILE *port;
 487 {
 488   scm_sizet len = size * nitems;
 489   scm_sizet i = 0;
 490   for (; i < len; i++)
 491     putc (ptr[i], port);
 492   return len;
 493 }
 494
 495 #define ffwrite pwrite
 496 #else
 497 #define ffwrite fwrite
 498 #endif
 499
 500 static int
 501 local_fclose (SCM port)
 502 {
 503   FILE *fp = (FILE *) SCM_STREAM (port);
 504
 505   return fclose (fp);
 506 }
 507
 508 static int
 509 local_fflush (SCM port)
 510 {
 511   FILE *fp = (FILE *) SCM_STREAM (port);
 512   return fflush (fp);
 513   FPORT_ALL_OKAY (port);
 514 }
 515
 516 static int
 517 local_fputc (int c, SCM port)
 518 {
 519   FILE *fp = (FILE *) SCM_STREAM (port);
 520
 521   pre_write (port);
 522   return fputc (c, fp);
 523 }
 524
 525 static int
 526 local_fputs (char *s, SCM port)
 527 {
 528   FILE *fp = (FILE *) SCM_STREAM (port);
 529   pre_write (port);
 530   return fputs (s, fp);
 531 }
 532
 533 static scm_sizet
 534 local_ffwrite (char *ptr,
 535                scm_sizet size,
 536                scm_sizet nitems,
 537                SCM port)
 538 {
 539   FILE *fp = (FILE *) SCM_STREAM (port);
 540   pre_write (port);
 541   return ffwrite (ptr, size, nitems, fp);
 542 }
 543
 544 static int
 545 print_pipe_port (SCM exp, SCM port, scm_print_state *pstate)
 546 {
 547   scm_prinport (exp, port, "pipe");
 548   return 1;
 549 }
 550
 551 static int
 552 local_pclose (SCM port)
 553 {
 554   FILE *fp = (FILE *) SCM_STREAM (port);
 555
 556   return pclose (fp);
 557 }
 558
 559 \f
 560 /* The file and pipe port scm_ptobfuns structures themselves.  */
 561
 562 scm_ptobfuns scm_fptob =
 563 {
 564   0,
 565   local_fclose,
 566   prinfport,
 567   0,
 568   local_fputc,
 569   local_fputs,
 570   local_ffwrite,
 571   local_fflush,
 572   local_fgetc,
 573   local_fgets,
 574   local_fclose
 575 };
 576
 577 /* {Pipe ports} */
 578 scm_ptobfuns scm_pipob =
 579 {
 580   0,
 581   local_pclose,
 582   print_pipe_port,
 583   0,
 584   local_fputc,
 585   local_fputs,
 586   local_ffwrite,
 587   local_fflush,
 588   local_fgetc,
 589   scm_generic_fgets,
 590   local_pclose
 591 };
 592
 593 void
 594 scm_init_fports ()
 595 {
 596 #include "fports.x"
 597   scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
 598   scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
 599   scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
 600 }