libguile/fports.c

   1 /*      Copyright (C) 1995,1996,1997,1998,1999 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 <fcntl.h>
  45 #include "_scm.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 #ifdef HAVE_ST_BLKSIZE
  58 #include <sys/stat.h>
  59 #endif
  60
  61 #include <errno.h>
  62
  63 #include "iselect.h"
  64
  65 /* create FPORT buffer with specified sizes (or -1 to use default size or
  66    0 for no buffer.  */
  67 static void
  68 scm_fport_buffer_add (SCM port, int read_size, int write_size)
  69 {
  70   struct scm_fport *fp = SCM_FSTREAM (port);
  71    scm_port *pt = SCM_PTAB_ENTRY (port);
  72   char *s_scm_fport_buffer_add = "scm_fport_buffer_add";
  73
  74   if (read_size == -1 || write_size == -1)
  75     {
  76       int default_size;
  77 #ifdef HAVE_ST_BLKSIZE
  78       struct stat st;
  79
  80       if (fstat (fp->fdes, &st) == -1)
  81         scm_syserror (s_scm_fport_buffer_add);
  82       default_size = st.st_blksize;
  83 #else
  84       default_size = 1024;
  85 #endif
  86       if (read_size == -1)
  87         read_size = default_size;
  88       if (write_size == -1)
  89         write_size = default_size;
  90     }
  91
  92   if (SCM_INPORTP (port) && read_size > 0)
  93     {
  94       pt->read_buf = malloc (read_size);
  95       if (pt->read_buf == NULL)
  96         scm_memory_error (s_scm_fport_buffer_add);
  97       pt->read_pos = pt->read_end = pt->read_buf;
  98       pt->read_buf_size = read_size;
  99     }
 100   else
 101     {
 102       pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
 103       pt->read_buf_size = 1;
 104     }
 105
 106   if (SCM_OUTPORTP (port) && write_size > 0)
 107     {
 108       pt->write_buf = malloc (write_size);
 109       if (pt->write_buf == NULL)
 110         scm_memory_error (s_scm_fport_buffer_add);
 111       pt->write_pos = pt->write_buf;
 112       pt->write_buf_size = write_size;
 113     }
 114   else
 115     {
 116       pt->write_buf = pt->write_pos = &pt->shortbuf;
 117       pt->write_buf_size = 1;
 118     }
 119
 120   pt->write_end = pt->write_buf + pt->write_buf_size;
 121   if (read_size > 0 || write_size > 0)
 122     SCM_SETCAR (port, SCM_CAR (port) & ~SCM_BUF0);
 123   else
 124     SCM_SETCAR (port, (SCM_CAR (port) | SCM_BUF0));
 125 }
 126
 127 SCM_PROC (s_setvbuf, "setvbuf", 2, 1, 0, scm_setvbuf);
 128 SCM
 129 scm_setvbuf (SCM port, SCM mode, SCM size)
 130 {
 131   int cmode, csize;
 132   scm_port *pt;
 133
 134   port = SCM_COERCE_OUTPORT (port);
 135
 136   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1,
 137               s_setvbuf);
 138   SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_setvbuf);
 139   cmode = SCM_INUM (mode);
 140   if (cmode != _IONBF && cmode != _IOFBF)
 141     scm_out_of_range (s_setvbuf, mode);
 142   if (SCM_UNBNDP (size))
 143     {
 144       if (cmode == _IOFBF)
 145         csize = -1;
 146       else
 147         csize = 0;
 148     }
 149   else
 150     {
 151       SCM_ASSERT (SCM_INUMP (size), size, SCM_ARG3, s_setvbuf);
 152       csize = SCM_INUM (size);
 153       if (csize < 0 || (cmode == _IONBF && csize > 0))
 154         scm_out_of_range (s_setvbuf, size);
 155     }
 156   pt = SCM_PTAB_ENTRY (port);
 157
 158   /* silently discards buffered chars.  */
 159   if (pt->read_buf != &pt->shortbuf)
 160     scm_must_free (pt->read_buf);
 161   if (pt->write_buf != &pt->shortbuf)
 162     scm_must_free (pt->write_buf);
 163
 164   scm_fport_buffer_add (port, csize, csize);
 165   return SCM_UNSPECIFIED;
 166 }
 167
 168 /* Move ports with the specified file descriptor to new descriptors,
 169  * reseting the revealed count to 0.
 170  */
 171
 172 void
 173 scm_evict_ports (fd)
 174      int fd;
 175 {
 176   int i;
 177
 178   for (i = 0; i < scm_port_table_size; i++)
 179     {
 180       SCM port = scm_port_table[i]->port;
 181
 182       if (SCM_FPORTP (port))
 183         {
 184           struct scm_fport *fp = SCM_FSTREAM (port);
 185
 186           if (fp->fdes == fd)
 187             {
 188               fp->fdes = dup (fd);
 189               if (fp->fdes == -1)
 190                 scm_syserror ("scm_evict_ports");
 191               scm_set_port_revealed_x (port, SCM_MAKINUM (0));
 192             }
 193         }
 194     }
 195 }
 196
 197 /* scm_open_file
 198  * Return a new port open on a given file.
 199  *
 200  * The mode string must match the pattern: [rwa+]** which
 201  * is interpreted in the usual unix way.
 202  *
 203  * Return the new port.
 204  */
 205 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 206
 207 SCM
 208 scm_open_file (filename, modes)
 209      SCM filename;
 210      SCM modes;
 211 {
 212   SCM port;
 213   int fdes;
 214   int flags = 0;
 215   char *file;
 216   char *mode;
 217   char *ptr;
 218
 219   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 220   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 221   if (SCM_SUBSTRP (filename))
 222     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 223   if (SCM_SUBSTRP (modes))
 224     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 225
 226   file = SCM_ROCHARS (filename);
 227   mode = SCM_ROCHARS (modes);
 228
 229   switch (*mode)
 230     {
 231     case 'r':
 232       flags |= O_RDONLY;
 233       break;
 234     case 'w':
 235       flags |= O_WRONLY | O_CREAT | O_TRUNC;
 236       break;
 237     case 'a':
 238       flags |= O_WRONLY | O_CREAT | O_APPEND;
 239       break;
 240     default:
 241       scm_out_of_range (s_open_file, modes);
 242     }
 243   ptr = mode + 1;
 244   while (*ptr != '\0')
 245     {
 246       switch (*ptr)
 247         {
 248         case '+':
 249           flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
 250           break;
 251         case '0':  /* unbuffered: handled later.  */
 252         case 'b':  /* 'binary' mode: ignored.  */
 253           break;
 254         default:
 255           scm_out_of_range (s_open_file, modes);
 256         }
 257       ptr++;
 258     }
 259   SCM_SYSCALL (fdes = open (file, flags, 0666));
 260   if (fdes == -1)
 261     {
 262       int en = errno;
 263
 264       scm_syserror_msg (s_open_file, "%s: %S",
 265                         scm_cons (scm_makfrom0str (strerror (en)),
 266                                   scm_cons (filename, SCM_EOL)),
 267                         en);
 268     }
 269   port = scm_fdes_to_port (fdes, mode, filename);
 270   return port;
 271 }
 272
 273 \f
 274 /* Building Guile ports from a file descriptor.  */
 275
 276 /* Build a Scheme port from an open file descriptor `fdes'.
 277    MODE indicates whether FILE is open for reading or writing; it uses
 278       the same notation as open-file's second argument.
 279    Use NAME as the port's filename.  */
 280
 281 SCM
 282 scm_fdes_to_port (int fdes, char *mode, SCM name)
 283 {
 284   long mode_bits = scm_mode_bits (mode);
 285   SCM port;
 286   scm_port *pt;
 287
 288   SCM_NEWCELL (port);
 289   SCM_DEFER_INTS;
 290   pt = scm_add_to_port_table (port);
 291   SCM_SETPTAB_ENTRY (port, pt);
 292   SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
 293
 294   {
 295     struct scm_fport *fp
 296       = (struct scm_fport *) malloc (sizeof (struct scm_fport));
 297     if (fp == NULL)
 298       scm_memory_error ("scm_fdes_to_port");
 299     fp->fdes = fdes;
 300     pt->rw_random = (mode_bits & SCM_RDNG) && (mode_bits & SCM_WRTNG)
 301       && SCM_FDES_RANDOM_P (fdes);
 302     SCM_SETSTREAM (port, fp);
 303     if (mode_bits & SCM_BUF0)
 304       scm_fport_buffer_add (port, 0, 0);
 305     else
 306       scm_fport_buffer_add (port, -1, -1);
 307   }
 308   SCM_PTAB_ENTRY (port)->file_name = name;
 309   SCM_ALLOW_INTS;
 310   return port;
 311 }
 312
 313
 314 /* Check whether an fport's fdes can supply input.  */
 315 static int
 316 fport_input_waiting_p (SCM port)
 317 {
 318   int fdes = SCM_FSTREAM (port)->fdes;
 319
 320 #ifdef HAVE_SELECT
 321   struct timeval timeout;
 322   SELECT_TYPE read_set;
 323   SELECT_TYPE write_set;
 324   SELECT_TYPE except_set;
 325
 326   FD_ZERO (&read_set);
 327   FD_ZERO (&write_set);
 328   FD_ZERO (&except_set);
 329
 330   FD_SET (fdes, &read_set);
 331
 332   timeout.tv_sec = 0;
 333   timeout.tv_usec = 0;
 334
 335   if (select (SELECT_SET_SIZE,
 336               &read_set, &write_set, &except_set, &timeout)
 337       < 0)
 338     scm_syserror ("fport_input_waiting_p");
 339   return FD_ISSET (fdes, &read_set);
 340 #elif defined (FIONREAD)
 341   int remir;
 342   ioctl(fdes, FIONREAD, &remir);
 343   return remir;
 344 #else
 345   scm_misc_error ("fport_input_waiting_p",
 346                   "Not fully implemented on this platform",
 347                   SCM_EOL);
 348 #endif
 349 }
 350
 351 \f
 352 static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 353
 354 static int
 355 prinfport (exp, port, pstate)
 356      SCM exp;
 357      SCM port;
 358      scm_print_state *pstate;
 359 {
 360   scm_puts ("#<", port);
 361   scm_print_port_mode (exp, port);
 362   if (SCM_OPFPORTP (exp))
 363     {
 364       int fdes;
 365       SCM name = SCM_PTAB_ENTRY (exp)->file_name;
 366       scm_puts (SCM_NIMP (name) && SCM_ROSTRINGP (name)
 367                 ? SCM_ROCHARS (name)
 368                 : SCM_PTOBNAME (SCM_PTOBNUM (exp)),
 369                 port);
 370       scm_putc (' ', port);
 371       fdes = (SCM_FSTREAM (exp))->fdes;
 372
 373       if (isatty (fdes))
 374         scm_puts (ttyname (fdes), port);
 375       else
 376         scm_intprint (fdes, 10, port);
 377     }
 378   else
 379     {
 380       scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 381       scm_putc (' ', port);
 382       scm_intprint (SCM_CDR (exp), 16, port);
 383     }
 384   scm_putc ('>', port);
 385   return 1;
 386 }
 387
 388 #ifdef GUILE_ISELECT
 389 /* thread-local block for input on fport's fdes.  */
 390 static void
 391 fport_wait_for_input (SCM port)
 392 {
 393   int fdes = SCM_FSTREAM (port)->fdes;
 394
 395   if (!fport_input_waiting_p (port))
 396     {
 397       int n;
 398       SELECT_TYPE readfds;
 399       int flags = fcntl (fdes, F_GETFL);
 400
 401       if (flags == -1)
 402         scm_syserror ("scm_fdes_wait_for_input");
 403       if (!(flags & O_NONBLOCK))
 404         do
 405           {
 406             FD_ZERO (&readfds);
 407             FD_SET (fdes, &readfds);
 408             n = scm_internal_select (fdes + 1, &readfds, NULL, NULL, NULL);
 409           }
 410         while (n == -1 && errno == EINTR);
 411     }
 412 }
 413 #endif
 414
 415 static void local_fflush (SCM port);
 416
 417 /* fill a port's read-buffer with a single read.
 418    returns the first char and moves the read_pos pointer past it.
 419    or returns EOF if end of file.  */
 420 static int
 421 fport_fill_buffer (SCM port)
 422 {
 423   int count;
 424   scm_port *pt = SCM_PTAB_ENTRY (port);
 425   struct scm_fport *fp = SCM_FSTREAM (port);
 426
 427 #ifdef GUILE_ISELECT
 428   fport_wait_for_input (port);
 429 #endif
 430   SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
 431   if (count == -1)
 432     scm_syserror ("fport_fill_buffer");
 433   if (count == 0)
 434     return EOF;
 435   else
 436     {
 437       pt->read_pos = pt->read_buf;
 438       pt->read_end = pt->read_buf + count;
 439       return *pt->read_buf;
 440     }
 441 }
 442
 443 static off_t
 444 local_seek (SCM port, off_t offset, int whence)
 445 {
 446   struct scm_fport *fp = SCM_FSTREAM (port);
 447   off_t result = lseek (fp->fdes, offset, whence);
 448
 449   if (result == -1)
 450     scm_syserror ("local_seek");
 451   return result;
 452 }
 453
 454 static void
 455 local_ftruncate (SCM port, off_t length)
 456 {
 457   struct scm_fport *fp = SCM_FSTREAM (port);
 458
 459   if (ftruncate (fp->fdes, length) == -1)
 460     scm_syserror ("ftruncate");
 461 }
 462
 463 /* becomes 1 when process is exiting: exception handling is disabled. */
 464 extern int terminating;
 465
 466 static void
 467 local_fflush (SCM port)
 468 {
 469   scm_port *pt = SCM_PTAB_ENTRY (port);
 470   struct scm_fport *fp = SCM_FSTREAM (port);
 471   char *ptr = pt->write_buf;
 472   int init_size = pt->write_pos - pt->write_buf;
 473   int remaining = init_size;
 474
 475   while (remaining > 0)
 476     {
 477       int count;
 478
 479       SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
 480       if (count < 0)
 481         {
 482           /* error.  assume nothing was written this call, but
 483              fix up the buffer for any previous successful writes.  */
 484           int done = init_size - remaining;
 485
 486           if (done > 0)
 487             {
 488               int i;
 489
 490               for (i = 0; i < remaining; i++)
 491                 {
 492                   *(pt->write_buf + i) = *(pt->write_buf + done + i);
 493                 }
 494               pt->write_pos = pt->write_buf + remaining;
 495             }
 496           if (!terminating)
 497             scm_syserror ("local_fflush");
 498           else
 499             {
 500               const char *msg = "Error: could not flush file-descriptor ";
 501               char buf[11];
 502
 503               write (2, msg, strlen (msg));
 504               sprintf (buf, "%d\n", fp->fdes);
 505               write (2, buf, strlen (buf));
 506
 507               count = remaining;
 508             }
 509         }
 510       ptr += count;
 511       remaining -= count;
 512     }
 513   pt->write_pos = pt->write_buf;
 514   pt->rw_active = 0;
 515 }
 516
 517 /* clear the read buffer and adjust the file position for unread bytes. */
 518 static void
 519 local_read_flush (SCM port, int offset)
 520 {
 521   struct scm_fport *fp = SCM_FSTREAM (port);
 522   scm_port *pt = SCM_PTAB_ENTRY (port);
 523
 524   offset += pt->read_end - pt->read_pos;
 525
 526   if (offset > 0)
 527     {
 528       pt->read_pos = pt->read_end;
 529       /* will throw error if unread-char used at beginning of file
 530          then attempting to write.  seems correct.  */
 531       if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
 532         scm_syserror ("local_read_flush");
 533     }
 534   pt->rw_active = 0;
 535 }
 536
 537 static int
 538 local_fclose (SCM port)
 539 {
 540   struct scm_fport *fp = SCM_FSTREAM (port);
 541   scm_port *pt = SCM_PTAB_ENTRY (port);
 542   int rv;
 543
 544   local_fflush (port);
 545   SCM_SYSCALL (rv = close (fp->fdes));
 546   if (rv == -1 && errno != EBADF)
 547     scm_syserror ("local_fclose");
 548   if (pt->read_buf == pt->putback_buf)
 549     pt->read_buf = pt->saved_read_buf;
 550   if (pt->read_buf != &pt->shortbuf)
 551     free (pt->read_buf);
 552   if (pt->write_buf != &pt->shortbuf)
 553     free (pt->write_buf);
 554   free ((char *) fp);
 555   return rv;
 556 }
 557
 558 static scm_sizet
 559 local_free (SCM port)
 560 {
 561   local_fclose (port);
 562   return 0;
 563 }
 564
 565 void scm_make_fptob (void); /* Called from ports.c */
 566
 567 void
 568 scm_make_fptob ()
 569 {
 570   long tc = scm_make_port_type ("file", fport_fill_buffer, local_fflush);
 571   scm_set_port_free            (tc, local_free);
 572   scm_set_port_print           (tc, prinfport);
 573   scm_set_port_flush_input     (tc, local_read_flush);
 574   scm_set_port_close           (tc, local_fclose);
 575   scm_set_port_seek            (tc, local_seek);
 576   scm_set_port_truncate        (tc, local_ftruncate);
 577   scm_set_port_input_waiting_p (tc, fport_input_waiting_p);
 578 }
 579
 580 void
 581 scm_init_fports ()
 582 {
 583 #include "fports.x"
 584   scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
 585   scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
 586   scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
 587 }