guile18/libguile/fports.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #define _LARGEFILE64_SOURCE      /* ask for stat64 etc */
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <stdio.h>
  27 #include <fcntl.h>
  28 #include "libguile/_scm.h"
  29 #include "libguile/strings.h"
  30 #include "libguile/validate.h"
  31 #include "libguile/gc.h"
  32 #include "libguile/posix.h"
  33 #include "libguile/dynwind.h"
  34
  35 #include "libguile/fports.h"
  36
  37 #ifdef HAVE_STRING_H
  38 #include <string.h>
  39 #endif
  40 #ifdef HAVE_UNISTD_H
  41 #include <unistd.h>
  42 #endif
  43 #ifdef HAVE_IO_H
  44 #include <io.h>
  45 #endif
  46 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
  47 #include <sys/stat.h>
  48 #endif
  49
  50 #include <errno.h>
  51 #include <sys/types.h>
  52
  53 #include "libguile/iselect.h"
  54
  55 /* Some defines for Windows (native port, not Cygwin). */
  56 #ifdef __MINGW32__
  57 # include <sys/stat.h>
  58 # include <winsock2.h>
  59 #endif /* __MINGW32__ */
  60
  61 /* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
  62    already, but have this code here in case that wasn't so in past versions,
  63    or perhaps to help other minimal DOS environments.
  64
  65    gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
  66    might be possibilities if we've got other systems without ftruncate.  */
  67
  68 #if HAVE_CHSIZE && ! HAVE_FTRUNCATE
  69 # define ftruncate(fd, size) chsize (fd, size)
  70 #undef HAVE_FTRUNCATE
  71 #define HAVE_FTRUNCATE 1
  72 #endif
  73
  74 #if SIZEOF_OFF_T == SIZEOF_INT
  75 #define OFF_T_MAX  INT_MAX
  76 #define OFF_T_MIN  INT_MIN
  77 #elif SIZEOF_OFF_T == SIZEOF_LONG
  78 #define OFF_T_MAX  LONG_MAX
  79 #define OFF_T_MIN  LONG_MIN
  80 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
  81 #define OFF_T_MAX  LONG_LONG_MAX
  82 #define OFF_T_MIN  LONG_LONG_MIN
  83 #else
  84 #error Oops, unknown OFF_T size
  85 #endif
  86
  87 scm_t_bits scm_tc16_fport;
  88
  89
  90 /* default buffer size, used if the O/S won't supply a value.  */
  91 static const size_t default_buffer_size = 1024;
  92
  93 /* create FPORT buffer with specified sizes (or -1 to use default size or
  94    0 for no buffer.  */
  95 static void
  96 scm_fport_buffer_add (SCM port, long read_size, int write_size)
  97 #define FUNC_NAME "scm_fport_buffer_add"
  98 {
  99   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 100
 101   if (read_size == -1 || write_size == -1)
 102     {
 103       size_t default_size;
 104 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
 105       struct stat st;
 106       scm_t_fport *fp = SCM_FSTREAM (port);
 107
 108       default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
 109         : st.st_blksize;
 110 #else
 111       default_size = default_buffer_size;
 112 #endif
 113       if (read_size == -1)
 114         read_size = default_size;
 115       if (write_size == -1)
 116         write_size = default_size;
 117     }
 118
 119   if (SCM_INPUT_PORT_P (port) && read_size > 0)
 120     {
 121       pt->read_buf = scm_gc_malloc (read_size, "port buffer");
 122       pt->read_pos = pt->read_end = pt->read_buf;
 123       pt->read_buf_size = read_size;
 124     }
 125   else
 126     {
 127       pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
 128       pt->read_buf_size = 1;
 129     }
 130
 131   if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
 132     {
 133       pt->write_buf = scm_gc_malloc (write_size, "port buffer");
 134       pt->write_pos = pt->write_buf;
 135       pt->write_buf_size = write_size;
 136     }
 137   else
 138     {
 139       pt->write_buf = pt->write_pos = &pt->shortbuf;
 140       pt->write_buf_size = 1;
 141     }
 142
 143   pt->write_end = pt->write_buf + pt->write_buf_size;
 144   if (read_size > 0 || write_size > 0)
 145     SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
 146   else
 147     SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
 148 }
 149 #undef FUNC_NAME
 150
 151 SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
 152             (SCM port, SCM mode, SCM size),
 153             "Set the buffering mode for @var{port}.  @var{mode} can be:\n"
 154             "@table @code\n"
 155             "@item _IONBF\n"
 156             "non-buffered\n"
 157             "@item _IOLBF\n"
 158             "line buffered\n"
 159             "@item _IOFBF\n"
 160             "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
 161             "If @var{size} is omitted, a default size will be used.\n"
 162             "@end table")
 163 #define FUNC_NAME s_scm_setvbuf
 164 {
 165   int cmode;
 166   long csize;
 167   scm_t_port *pt;
 168
 169   port = SCM_COERCE_OUTPORT (port);
 170
 171   SCM_VALIDATE_OPFPORT (1,port);
 172   cmode = scm_to_int (mode);
 173   if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
 174     scm_out_of_range (FUNC_NAME, mode);
 175
 176   if (cmode == _IOLBF)
 177     {
 178       SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
 179       cmode = _IOFBF;
 180     }
 181   else
 182     {
 183       SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
 184     }
 185
 186   if (SCM_UNBNDP (size))
 187     {
 188       if (cmode == _IOFBF)
 189         csize = -1;
 190       else
 191         csize = 0;
 192     }
 193   else
 194     {
 195       csize = scm_to_int (size);
 196       if (csize < 0 || (cmode == _IONBF && csize > 0))
 197         scm_out_of_range (FUNC_NAME, size);
 198     }
 199
 200   pt = SCM_PTAB_ENTRY (port);
 201
 202   /* silently discards buffered and put-back chars.  */
 203   if (pt->read_buf == pt->putback_buf)
 204     {
 205       pt->read_buf = pt->saved_read_buf;
 206       pt->read_pos = pt->saved_read_pos;
 207       pt->read_end = pt->saved_read_end;
 208       pt->read_buf_size = pt->saved_read_buf_size;
 209     }
 210   if (pt->read_buf != &pt->shortbuf)
 211     scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
 212   if (pt->write_buf != &pt->shortbuf)
 213     scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
 214
 215   scm_fport_buffer_add (port, csize, csize);
 216   return SCM_UNSPECIFIED;
 217 }
 218 #undef FUNC_NAME
 219
 220 /* Move ports with the specified file descriptor to new descriptors,
 221  * resetting the revealed count to 0.
 222  */
 223
 224 void
 225 scm_evict_ports (int fd)
 226 {
 227   long i;
 228
 229   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
 230
 231   for (i = 0; i < scm_i_port_table_size; i++)
 232     {
 233       SCM port = scm_i_port_table[i]->port;
 234
 235       if (SCM_FPORTP (port))
 236         {
 237           scm_t_fport *fp = SCM_FSTREAM (port);
 238
 239           if (fp->fdes == fd)
 240             {
 241               fp->fdes = dup (fd);
 242               if (fp->fdes == -1)
 243                 scm_syserror ("scm_evict_ports");
 244               scm_set_port_revealed_x (port, scm_from_int (0));
 245             }
 246         }
 247     }
 248
 249   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 250 }
 251
 252
 253 SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
 254             (SCM obj),
 255             "Determine whether @var{obj} is a port that is related to a file.")
 256 #define FUNC_NAME s_scm_file_port_p
 257 {
 258   return scm_from_bool (SCM_FPORTP (obj));
 259 }
 260 #undef FUNC_NAME
 261
 262
 263 /* scm_open_file
 264  * Return a new port open on a given file.
 265  *
 266  * The mode string must match the pattern: [rwa+]** which
 267  * is interpreted in the usual unix way.
 268  *
 269  * Return the new port.
 270  */
 271 SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
 272            (SCM filename, SCM mode),
 273             "Open the file whose name is @var{filename}, and return a port\n"
 274             "representing that file.  The attributes of the port are\n"
 275             "determined by the @var{mode} string.  The way in which this is\n"
 276             "interpreted is similar to C stdio.  The first character must be\n"
 277             "one of the following:\n"
 278             "@table @samp\n"
 279             "@item r\n"
 280             "Open an existing file for input.\n"
 281             "@item w\n"
 282             "Open a file for output, creating it if it doesn't already exist\n"
 283             "or removing its contents if it does.\n"
 284             "@item a\n"
 285             "Open a file for output, creating it if it doesn't already\n"
 286             "exist.  All writes to the port will go to the end of the file.\n"
 287             "The \"append mode\" can be turned off while the port is in use\n"
 288             "@pxref{Ports and File Descriptors, fcntl}\n"
 289             "@end table\n"
 290             "The following additional characters can be appended:\n"
 291             "@table @samp\n"
 292             "@item b\n"
 293             "Open the underlying file in binary mode, if supported by the operating system. "
 294             "@item +\n"
 295             "Open the port for both input and output.  E.g., @code{r+}: open\n"
 296             "an existing file for both input and output.\n"
 297             "@item 0\n"
 298             "Create an \"unbuffered\" port.  In this case input and output\n"
 299             "operations are passed directly to the underlying port\n"
 300             "implementation without additional buffering.  This is likely to\n"
 301             "slow down I/O operations.  The buffering mode can be changed\n"
 302             "while a port is in use @pxref{Ports and File Descriptors,\n"
 303             "setvbuf}\n"
 304             "@item l\n"
 305             "Add line-buffering to the port.  The port output buffer will be\n"
 306             "automatically flushed whenever a newline character is written.\n"
 307             "@end table\n"
 308             "In theory we could create read/write ports which were buffered\n"
 309             "in one direction only.  However this isn't included in the\n"
 310             "current interfaces.  If a file cannot be opened with the access\n"
 311             "requested, @code{open-file} throws an exception.")
 312 #define FUNC_NAME s_scm_open_file
 313 {
 314   SCM port;
 315   int fdes;
 316   int flags = 0;
 317   char *file;
 318   char *md;
 319   char *ptr;
 320
 321   scm_dynwind_begin (0);
 322
 323   file = scm_to_locale_string (filename);
 324   scm_dynwind_free (file);
 325
 326   md = scm_to_locale_string (mode);
 327   scm_dynwind_free (md);
 328
 329   switch (*md)
 330     {
 331     case 'r':
 332       flags |= O_RDONLY;
 333       break;
 334     case 'w':
 335       flags |= O_WRONLY | O_CREAT | O_TRUNC;
 336       break;
 337     case 'a':
 338       flags |= O_WRONLY | O_CREAT | O_APPEND;
 339       break;
 340     default:
 341       scm_out_of_range (FUNC_NAME, mode);
 342     }
 343   ptr = md + 1;
 344   while (*ptr != '\0')
 345     {
 346       switch (*ptr)
 347         {
 348         case '+':
 349           flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
 350           break;
 351         case 'b':
 352 #if defined (O_BINARY)
 353           flags |= O_BINARY;
 354 #endif
 355           break;
 356         case '0':  /* unbuffered: handled later.  */
 357         case 'l':  /* line buffered: handled during output.  */
 358           break;
 359         default:
 360           scm_out_of_range (FUNC_NAME, mode);
 361         }
 362       ptr++;
 363     }
 364   SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
 365   if (fdes == -1)
 366     {
 367       int en = errno;
 368
 369       SCM_SYSERROR_MSG ("~A: ~S",
 370                         scm_cons (scm_strerror (scm_from_int (en)),
 371                                   scm_cons (filename, SCM_EOL)), en);
 372     }
 373   port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);
 374
 375   scm_dynwind_end ();
 376
 377   return port;
 378 }
 379 #undef FUNC_NAME
 380
 381 \f
 382 #ifdef __MINGW32__
 383 /*
 384  * Try getting the appropiate file flags for a given file descriptor
 385  * under Windows. This incorporates some fancy operations because Windows
 386  * differentiates between file, pipe and socket descriptors.
 387  */
 388 #ifndef O_ACCMODE
 389 # define O_ACCMODE 0x0003
 390 #endif
 391
 392 static int getflags (int fdes)
 393 {
 394   int flags = 0;
 395   struct stat buf;
 396   int error, optlen = sizeof (int);
 397
 398   /* Is this a socket ? */
 399   if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
 400     flags = O_RDWR;
 401   /* Maybe a regular file ? */
 402   else if (fstat (fdes, &buf) < 0)
 403     flags = -1;
 404   else
 405     {
 406       /* Or an anonymous pipe handle ? */
 407       if (buf.st_mode & _S_IFIFO)
 408         flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
 409                                NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
 410       /* stdin ? */
 411       else if (fdes == fileno (stdin) && isatty (fdes))
 412         flags = O_RDONLY;
 413       /* stdout / stderr ? */
 414       else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
 415                isatty (fdes))
 416         flags = O_WRONLY;
 417       else
 418         flags = buf.st_mode;
 419     }
 420   return flags;
 421 }
 422 #endif /* __MINGW32__ */
 423
 424 /* Building Guile ports from a file descriptor.  */
 425
 426 /* Build a Scheme port from an open file descriptor `fdes'.
 427    MODE indicates whether FILE is open for reading or writing; it uses
 428       the same notation as open-file's second argument.
 429    NAME is a string to be used as the port's filename.
 430 */
 431 SCM
 432 scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
 433 #define FUNC_NAME "scm_fdes_to_port"
 434 {
 435   SCM port;
 436   scm_t_port *pt;
 437   int flags;
 438
 439   /* test that fdes is valid.  */
 440 #ifdef __MINGW32__
 441   flags = getflags (fdes);
 442 #else
 443   flags = fcntl (fdes, F_GETFL, 0);
 444 #endif
 445   if (flags == -1)
 446     SCM_SYSERROR;
 447   flags &= O_ACCMODE;
 448   if (flags != O_RDWR
 449       && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
 450           || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
 451     {
 452       SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
 453     }
 454
 455   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
 456
 457   port = scm_new_port_table_entry (scm_tc16_fport);
 458   SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
 459   pt = SCM_PTAB_ENTRY(port);
 460   {
 461     scm_t_fport *fp
 462       = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");
 463
 464     fp->fdes = fdes;
 465     pt->rw_random = SCM_FDES_RANDOM_P (fdes);
 466     SCM_SETSTREAM (port, fp);
 467     if (mode_bits & SCM_BUF0)
 468       scm_fport_buffer_add (port, 0, 0);
 469     else
 470       scm_fport_buffer_add (port, -1, -1);
 471   }
 472   SCM_SET_FILENAME (port, name);
 473   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 474   return port;
 475 }
 476 #undef FUNC_NAME
 477
 478 SCM
 479 scm_fdes_to_port (int fdes, char *mode, SCM name)
 480 {
 481   return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
 482 }
 483
 484 /* Return a lower bound on the number of bytes available for input.  */
 485 static int
 486 fport_input_waiting (SCM port)
 487 {
 488 #ifdef HAVE_SELECT
 489   int fdes = SCM_FSTREAM (port)->fdes;
 490   struct timeval timeout;
 491   SELECT_TYPE read_set;
 492   SELECT_TYPE write_set;
 493   SELECT_TYPE except_set;
 494
 495   FD_ZERO (&read_set);
 496   FD_ZERO (&write_set);
 497   FD_ZERO (&except_set);
 498
 499   FD_SET (fdes, &read_set);
 500
 501   timeout.tv_sec = 0;
 502   timeout.tv_usec = 0;
 503
 504   if (select (SELECT_SET_SIZE,
 505               &read_set, &write_set, &except_set, &timeout)
 506       < 0)
 507     scm_syserror ("fport_input_waiting");
 508   return FD_ISSET (fdes, &read_set) ? 1 : 0;
 509
 510 #elif HAVE_IOCTL && defined (FIONREAD)
 511   /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
 512      (for use with winsock ioctlsocket()) but not ioctl().  */
 513   int fdes = SCM_FSTREAM (port)->fdes;
 514   int remir;
 515   ioctl(fdes, FIONREAD, &remir);
 516   return remir;
 517
 518 #else
 519   scm_misc_error ("fport_input_waiting",
 520                   "Not fully implemented on this platform",
 521                   SCM_EOL);
 522 #endif
 523 }
 524
 525 \f
 526 static int
 527 fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 528 {
 529   scm_puts ("#<", port);
 530   scm_print_port_mode (exp, port);
 531   if (SCM_OPFPORTP (exp))
 532     {
 533       int fdes;
 534       SCM name = SCM_FILENAME (exp);
 535       if (scm_is_string (name) || scm_is_symbol (name))
 536         scm_display (name, port);
 537       else
 538         scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 539       scm_putc (' ', port);
 540       fdes = (SCM_FSTREAM (exp))->fdes;
 541
 542 #ifdef HAVE_TTYNAME
 543       if (isatty (fdes))
 544         scm_display (scm_ttyname (exp), port);
 545       else
 546 #endif /* HAVE_TTYNAME */
 547         scm_intprint (fdes, 10, port);
 548     }
 549   else
 550     {
 551       scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 552       scm_putc (' ', port);
 553       scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
 554     }
 555   scm_putc ('>', port);
 556   return 1;
 557 }
 558
 559 #ifndef __MINGW32__
 560 /* thread-local block for input on fport's fdes.  */
 561 static void
 562 fport_wait_for_input (SCM port)
 563 {
 564   int fdes = SCM_FSTREAM (port)->fdes;
 565
 566   if (!fport_input_waiting (port))
 567     {
 568       int n;
 569       SELECT_TYPE readfds;
 570       int flags = fcntl (fdes, F_GETFL);
 571
 572       if (flags == -1)
 573         scm_syserror ("scm_fdes_wait_for_input");
 574       if (!(flags & O_NONBLOCK))
 575         do
 576           {
 577             FD_ZERO (&readfds);
 578             FD_SET (fdes, &readfds);
 579             n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
 580           }
 581         while (n == -1 && errno == EINTR);
 582     }
 583 }
 584 #endif /* !__MINGW32__ */
 585
 586 static void fport_flush (SCM port);
 587
 588 /* fill a port's read-buffer with a single read.  returns the first
 589    char or EOF if end of file.  */
 590 static int
 591 fport_fill_input (SCM port)
 592 {
 593   long count;
 594   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 595   scm_t_fport *fp = SCM_FSTREAM (port);
 596
 597 #ifndef __MINGW32__
 598   fport_wait_for_input (port);
 599 #endif /* !__MINGW32__ */
 600   SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
 601   if (count == -1)
 602     scm_syserror ("fport_fill_input");
 603   if (count == 0)
 604     return EOF;
 605   else
 606     {
 607       pt->read_pos = pt->read_buf;
 608       pt->read_end = pt->read_buf + count;
 609       return *pt->read_buf;
 610     }
 611 }
 612
 613 static off_t_or_off64_t
 614 fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
 615 {
 616   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 617   scm_t_fport *fp = SCM_FSTREAM (port);
 618   off_t_or_off64_t rv;
 619   off_t_or_off64_t result;
 620
 621   if (pt->rw_active == SCM_PORT_WRITE)
 622     {
 623       if (offset != 0 || whence != SEEK_CUR)
 624         {
 625           fport_flush (port);
 626           result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 627         }
 628       else
 629         {
 630           /* read current position without disturbing the buffer.  */
 631           rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 632           result = rv + (pt->write_pos - pt->write_buf);
 633         }
 634     }
 635   else if (pt->rw_active == SCM_PORT_READ)
 636     {
 637       if (offset != 0 || whence != SEEK_CUR)
 638         {
 639           /* could expand to avoid a second seek.  */
 640           scm_end_input (port);
 641           result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 642         }
 643       else
 644         {
 645           /* read current position without disturbing the buffer
 646              (particularly the unread-char buffer).  */
 647           rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 648           result = rv - (pt->read_end - pt->read_pos);
 649
 650           if (pt->read_buf == pt->putback_buf)
 651             result -= pt->saved_read_end - pt->saved_read_pos;
 652         }
 653     }
 654   else /* SCM_PORT_NEITHER */
 655     {
 656       result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 657     }
 658
 659   if (rv == -1)
 660     scm_syserror ("fport_seek");
 661
 662   return result;
 663 }
 664
 665 /* If we've got largefile and off_t isn't already off64_t then
 666    fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
 667    the port descriptor.
 668
 669    Otherwise if no largefile, or off_t is the same as off64_t (which is the
 670    case on NetBSD apparently), then fport_seek_or_seek64 is right to be
 671    fport_seek already.  */
 672
 673 #if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
 674 static off_t
 675 fport_seek (SCM port, off_t offset, int whence)
 676 {
 677   off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
 678   if (rv > OFF_T_MAX || rv < OFF_T_MIN)
 679     {
 680       errno = EOVERFLOW;
 681       scm_syserror ("fport_seek");
 682     }
 683   return (off_t) rv;
 684
 685 }
 686 #else
 687 #define fport_seek   fport_seek_or_seek64
 688 #endif
 689
 690 /* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
 691 SCM
 692 scm_i_fport_seek (SCM port, SCM offset, int how)
 693 {
 694   return scm_from_off_t_or_off64_t
 695     (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
 696 }
 697
 698 static void
 699 fport_truncate (SCM port, off_t length)
 700 {
 701   scm_t_fport *fp = SCM_FSTREAM (port);
 702
 703   if (ftruncate (fp->fdes, length) == -1)
 704     scm_syserror ("ftruncate");
 705 }
 706
 707 int
 708 scm_i_fport_truncate (SCM port, SCM length)
 709 {
 710   scm_t_fport *fp = SCM_FSTREAM (port);
 711   return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
 712 }
 713
 714 /* helper for fport_write: try to write data, using multiple system
 715    calls if required.  */
 716 #define FUNC_NAME "write_all"
 717 static void write_all (SCM port, const void *data, size_t remaining)
 718 {
 719   int fdes = SCM_FSTREAM (port)->fdes;
 720
 721   while (remaining > 0)
 722     {
 723       size_t done;
 724
 725       SCM_SYSCALL (done = write (fdes, data, remaining));
 726
 727       if (done == -1)
 728         SCM_SYSERROR;
 729       remaining -= done;
 730       data = ((const char *) data) + done;
 731     }
 732 }
 733 #undef FUNC_NAME
 734
 735 static void
 736 fport_write (SCM port, const void *data, size_t size)
 737 {
 738   /* this procedure tries to minimize the number of writes/flushes.  */
 739   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 740
 741   if (pt->write_buf == &pt->shortbuf
 742       || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
 743     {
 744       /* "unbuffered" port, or
 745          port with empty buffer and data won't fit in buffer. */
 746       write_all (port, data, size);
 747       return;
 748     }
 749
 750   {
 751     off_t space = pt->write_end - pt->write_pos;
 752
 753     if (size <= space)
 754       {
 755         /* data fits in buffer.  */
 756         memcpy (pt->write_pos, data, size);
 757         pt->write_pos += size;
 758         if (pt->write_pos == pt->write_end)
 759           {
 760             fport_flush (port);
 761             /* we can skip the line-buffering check if nothing's buffered. */
 762             return;
 763           }
 764       }
 765     else
 766       {
 767         memcpy (pt->write_pos, data, space);
 768         pt->write_pos = pt->write_end;
 769         fport_flush (port);
 770         {
 771           const void *ptr = ((const char *) data) + space;
 772           size_t remaining = size - space;
 773
 774           if (size >= pt->write_buf_size)
 775             {
 776               write_all (port, ptr, remaining);
 777               return;
 778             }
 779           else
 780             {
 781               memcpy (pt->write_pos, ptr, remaining);
 782               pt->write_pos += remaining;
 783             }
 784         }
 785       }
 786
 787     /* handle line buffering.  */
 788     if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
 789       fport_flush (port);
 790   }
 791 }
 792
 793 /* becomes 1 when process is exiting: normal exception handling won't
 794    work by this time.  */
 795 extern int scm_i_terminating;
 796
 797 static void
 798 fport_flush (SCM port)
 799 {
 800   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 801   scm_t_fport *fp = SCM_FSTREAM (port);
 802   unsigned char *ptr = pt->write_buf;
 803   long init_size = pt->write_pos - pt->write_buf;
 804   long remaining = init_size;
 805
 806   while (remaining > 0)
 807     {
 808       long count;
 809
 810       SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
 811       if (count < 0)
 812         {
 813           /* error.  assume nothing was written this call, but
 814              fix up the buffer for any previous successful writes.  */
 815           long done = init_size - remaining;
 816
 817           if (done > 0)
 818             {
 819               int i;
 820
 821               for (i = 0; i < remaining; i++)
 822                 {
 823                   *(pt->write_buf + i) = *(pt->write_buf + done + i);
 824                 }
 825               pt->write_pos = pt->write_buf + remaining;
 826             }
 827           if (scm_i_terminating)
 828             {
 829               const char *msg = "Error: could not flush file-descriptor ";
 830               char buf[11];
 831               size_t written;
 832
 833               written = write (2, msg, strlen (msg));
 834               sprintf (buf, "%d\n", fp->fdes);
 835               written = write (2, buf, strlen (buf));
 836
 837               count = remaining;
 838             }
 839           else if (scm_gc_running_p)
 840             {
 841               /* silently ignore the error.  scm_error would abort if we
 842                  called it now.  */
 843               count = remaining;
 844             }
 845           else
 846             scm_syserror ("fport_flush");
 847         }
 848       ptr += count;
 849       remaining -= count;
 850     }
 851   pt->write_pos = pt->write_buf;
 852   pt->rw_active = SCM_PORT_NEITHER;
 853 }
 854
 855 /* clear the read buffer and adjust the file position for unread bytes. */
 856 static void
 857 fport_end_input (SCM port, int offset)
 858 {
 859   scm_t_fport *fp = SCM_FSTREAM (port);
 860   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 861
 862   offset += pt->read_end - pt->read_pos;
 863
 864   if (offset > 0)
 865     {
 866       pt->read_pos = pt->read_end;
 867       /* will throw error if unread-char used at beginning of file
 868          then attempting to write.  seems correct.  */
 869       if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
 870         scm_syserror ("fport_end_input");
 871     }
 872   pt->rw_active = SCM_PORT_NEITHER;
 873 }
 874
 875 static int
 876 fport_close (SCM port)
 877 {
 878   scm_t_fport *fp = SCM_FSTREAM (port);
 879   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 880   int rv;
 881
 882   fport_flush (port);
 883   SCM_SYSCALL (rv = close (fp->fdes));
 884   if (rv == -1 && errno != EBADF)
 885     {
 886       if (scm_gc_running_p)
 887         /* silently ignore the error.  scm_error would abort if we
 888            called it now.  */
 889         ;
 890       else
 891         scm_syserror ("fport_close");
 892     }
 893   if (pt->read_buf == pt->putback_buf)
 894     pt->read_buf = pt->saved_read_buf;
 895   if (pt->read_buf != &pt->shortbuf)
 896     scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
 897   if (pt->write_buf != &pt->shortbuf)
 898     scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
 899   scm_gc_free (fp, sizeof (*fp), "file port");
 900   return rv;
 901 }
 902
 903 static size_t
 904 fport_free (SCM port)
 905 {
 906   fport_close (port);
 907   return 0;
 908 }
 909
 910 static scm_t_bits
 911 scm_make_fptob ()
 912 {
 913   scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);
 914
 915   scm_set_port_free            (tc, fport_free);
 916   scm_set_port_print           (tc, fport_print);
 917   scm_set_port_flush           (tc, fport_flush);
 918   scm_set_port_end_input       (tc, fport_end_input);
 919   scm_set_port_close           (tc, fport_close);
 920   scm_set_port_seek            (tc, fport_seek);
 921   scm_set_port_truncate        (tc, fport_truncate);
 922   scm_set_port_input_waiting   (tc, fport_input_waiting);
 923
 924   return tc;
 925 }
 926
 927 void
 928 scm_init_fports ()
 929 {
 930   scm_tc16_fport = scm_make_fptob ();
 931
 932   scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
 933   scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
 934   scm_c_define ("_IONBF", scm_from_int (_IONBF));
 935
 936 #include "libguile/fports.x"
 937 }
 938
 939 /*
 940   Local Variables:
 941   c-file-style: "gnu"
 942   End:
 943 */