libguile/fports.c

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