libguile/fports.c

   1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   2  *   2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #define _LARGEFILE64_SOURCE      /* ask for stat64 etc */
  23 #define _GNU_SOURCE              /* ask for LONG_LONG_MAX/LONG_LONG_MIN */
  24
  25 #ifdef HAVE_CONFIG_H
  26 #  include <config.h>
  27 #endif
  28
  29 #include <stdio.h>
  30 #include <fcntl.h>
  31
  32 #ifdef HAVE_STRING_H
  33 #include <string.h>
  34 #endif
  35 #ifdef HAVE_UNISTD_H
  36 #include <unistd.h>
  37 #endif
  38 #ifdef HAVE_IO_H
  39 #include <io.h>
  40 #endif
  41 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
  42 #include <sys/stat.h>
  43 #endif
  44 #include <poll.h>
  45 #include <errno.h>
  46 #include <sys/types.h>
  47 #include <sys/stat.h>
  48 #include <sys/select.h>
  49
  50 #include <full-write.h>
  51
  52 #include "libguile/_scm.h"
  53 #include "libguile/strings.h"
  54 #include "libguile/validate.h"
  55 #include "libguile/gc.h"
  56 #include "libguile/posix.h"
  57 #include "libguile/dynwind.h"
  58 #include "libguile/hashtab.h"
  59
  60 #include "libguile/fports.h"
  61
  62 #if SIZEOF_OFF_T == SIZEOF_INT
  63 #define OFF_T_MAX  INT_MAX
  64 #define OFF_T_MIN  INT_MIN
  65 #elif SIZEOF_OFF_T == SIZEOF_LONG
  66 #define OFF_T_MAX  LONG_MAX
  67 #define OFF_T_MIN  LONG_MIN
  68 #elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
  69 #define OFF_T_MAX  LONG_LONG_MAX
  70 #define OFF_T_MIN  LONG_LONG_MIN
  71 #else
  72 #error Oops, unknown OFF_T size
  73 #endif
  74
  75 scm_t_bits scm_tc16_fport;
  76
  77
  78 /* default buffer size, used if the O/S won't supply a value.  */
  79 static const size_t default_buffer_size = 1024;
  80
  81 /* create FPORT buffer with specified sizes (or -1 to use default size or
  82    0 for no buffer.  */
  83 static void
  84 scm_fport_buffer_add (SCM port, long read_size, int write_size)
  85 #define FUNC_NAME "scm_fport_buffer_add"
  86 {
  87   scm_t_port *pt = SCM_PTAB_ENTRY (port);
  88
  89   if (read_size == -1 || write_size == -1)
  90     {
  91       size_t default_size;
  92 #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
  93       struct stat st;
  94       scm_t_fport *fp = SCM_FSTREAM (port);
  95
  96       default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
  97         : st.st_blksize;
  98 #else
  99       default_size = default_buffer_size;
 100 #endif
 101       if (read_size == -1)
 102         read_size = default_size;
 103       if (write_size == -1)
 104         write_size = default_size;
 105     }
 106
 107   if (SCM_INPUT_PORT_P (port) && read_size > 0)
 108     {
 109       pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer");
 110       pt->read_pos = pt->read_end = pt->read_buf;
 111       pt->read_buf_size = read_size;
 112     }
 113   else
 114     {
 115       pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
 116       pt->read_buf_size = 1;
 117     }
 118
 119   if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
 120     {
 121       pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer");
 122       pt->write_pos = pt->write_buf;
 123       pt->write_buf_size = write_size;
 124     }
 125   else
 126     {
 127       pt->write_buf = pt->write_pos = &pt->shortbuf;
 128       pt->write_buf_size = 1;
 129     }
 130
 131   pt->write_end = pt->write_buf + pt->write_buf_size;
 132   if (read_size > 0 || write_size > 0)
 133     SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
 134   else
 135     SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
 136 }
 137 #undef FUNC_NAME
 138
 139 SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
 140             (SCM port, SCM mode, SCM size),
 141             "Set the buffering mode for @var{port}.  @var{mode} can be:\n"
 142             "@table @code\n"
 143             "@item _IONBF\n"
 144             "non-buffered\n"
 145             "@item _IOLBF\n"
 146             "line buffered\n"
 147             "@item _IOFBF\n"
 148             "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
 149             "If @var{size} is omitted, a default size will be used.\n"
 150             "@end table")
 151 #define FUNC_NAME s_scm_setvbuf
 152 {
 153   int cmode;
 154   long csize;
 155   size_t ndrained;
 156   char *drained;
 157   scm_t_port *pt;
 158
 159   port = SCM_COERCE_OUTPORT (port);
 160
 161   SCM_VALIDATE_OPFPORT (1,port);
 162   cmode = scm_to_int (mode);
 163   if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
 164     scm_out_of_range (FUNC_NAME, mode);
 165
 166   if (cmode == _IOLBF)
 167     {
 168       SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
 169       cmode = _IOFBF;
 170     }
 171   else
 172     {
 173       SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
 174     }
 175
 176   if (SCM_UNBNDP (size))
 177     {
 178       if (cmode == _IOFBF)
 179         csize = -1;
 180       else
 181         csize = 0;
 182     }
 183   else
 184     {
 185       csize = scm_to_int (size);
 186       if (csize < 0 || (cmode == _IONBF && csize > 0))
 187         scm_out_of_range (FUNC_NAME, size);
 188     }
 189
 190   pt = SCM_PTAB_ENTRY (port);
 191
 192   if (SCM_INPUT_PORT_P (port))
 193     {
 194       /* Drain pending input from PORT.  Don't use `scm_drain_input' since
 195          it returns a string, whereas we want binary input here.  */
 196       ndrained = pt->read_end - pt->read_pos;
 197       if (pt->read_buf == pt->putback_buf)
 198         ndrained += pt->saved_read_end - pt->saved_read_pos;
 199
 200       if (ndrained > 0)
 201         {
 202           drained = scm_gc_malloc_pointerless (ndrained, "file port");
 203           scm_take_from_input_buffers (port, drained, ndrained);
 204         }
 205     }
 206   else
 207     ndrained = 0;
 208
 209   if (SCM_OUTPUT_PORT_P (port))
 210     scm_flush_unlocked (port);
 211
 212   if (pt->read_buf == pt->putback_buf)
 213     {
 214       pt->read_buf = pt->saved_read_buf;
 215       pt->read_pos = pt->saved_read_pos;
 216       pt->read_end = pt->saved_read_end;
 217       pt->read_buf_size = pt->saved_read_buf_size;
 218     }
 219   if (pt->read_buf != &pt->shortbuf)
 220     scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
 221   if (pt->write_buf != &pt->shortbuf)
 222     scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
 223
 224   scm_fport_buffer_add (port, csize, csize);
 225
 226   if (ndrained > 0)
 227     /* Put DRAINED back to PORT.  */
 228     scm_unget_bytes ((unsigned char *) drained, ndrained, port);
 229
 230   return SCM_UNSPECIFIED;
 231 }
 232 #undef FUNC_NAME
 233
 234 /* Move ports with the specified file descriptor to new descriptors,
 235  * resetting the revealed count to 0.
 236  */
 237 static void
 238 scm_i_evict_port (void *closure, SCM port)
 239 {
 240   int fd = * (int*) closure;
 241
 242   if (SCM_FPORTP (port))
 243     {
 244       scm_t_port *p;
 245       scm_t_fport *fp;
 246
 247       /* XXX: In some cases, we can encounter a port with no associated ptab
 248          entry.  */
 249       p = SCM_PTAB_ENTRY (port);
 250       fp = (p != NULL) ? (scm_t_fport *) p->stream : NULL;
 251
 252       if ((fp != NULL) && (fp->fdes == fd))
 253         {
 254           fp->fdes = dup (fd);
 255           if (fp->fdes == -1)
 256             scm_syserror ("scm_evict_ports");
 257           scm_set_port_revealed_x (port, scm_from_int (0));
 258         }
 259     }
 260 }
 261
 262 void
 263 scm_evict_ports (int fd)
 264 {
 265   scm_c_port_for_each (scm_i_evict_port, (void *) &fd);
 266 }
 267
 268
 269 SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
 270             (SCM obj),
 271             "Determine whether @var{obj} is a port that is related to a file.")
 272 #define FUNC_NAME s_scm_file_port_p
 273 {
 274   return scm_from_bool (SCM_FPORTP (obj));
 275 }
 276 #undef FUNC_NAME
 277
 278
 279 static SCM sys_file_port_name_canonicalization;
 280 SCM_SYMBOL (sym_relative, "relative");
 281 SCM_SYMBOL (sym_absolute, "absolute");
 282
 283 static SCM
 284 fport_canonicalize_filename (SCM filename)
 285 {
 286   SCM mode = scm_fluid_ref (sys_file_port_name_canonicalization);
 287
 288   if (!scm_is_string (filename))
 289     {
 290       return filename;
 291     }
 292   else if (scm_is_eq (mode, sym_relative))
 293     {
 294       SCM path, rel;
 295
 296       path = scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
 297                                                     "%load-path"));
 298       rel = scm_i_relativize_path (filename, path);
 299
 300       return scm_is_true (rel) ? rel : filename;
 301     }
 302   else if (scm_is_eq (mode, sym_absolute))
 303     {
 304       char *str, *canon;
 305
 306       str = scm_to_locale_string (filename);
 307       canon = canonicalize_file_name (str);
 308       free (str);
 309
 310       return canon ? scm_take_locale_string (canon) : filename;
 311     }
 312   else
 313     {
 314       return filename;
 315     }
 316 }
 317
 318 /* scm_open_file_with_encoding
 319    Return a new port open on a given file.
 320
 321    The mode string must match the pattern: [rwa+]** which
 322    is interpreted in the usual unix way.
 323
 324    Unless binary mode is requested, the character encoding of the new
 325    port is determined as follows: First, if GUESS_ENCODING is true,
 326    'file-encoding' is used to guess the encoding of the file.  If
 327    GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used
 328    unless it is also false.  As a last resort, the default port encoding
 329    is used.  It is an error to pass a non-false GUESS_ENCODING or
 330    ENCODING if binary mode is requested.
 331
 332    Return the new port. */
 333 SCM
 334 scm_open_file_with_encoding (SCM filename, SCM mode,
 335                              SCM guess_encoding, SCM encoding)
 336 #define FUNC_NAME "open-file"
 337 {
 338   SCM port;
 339   int fdes, flags = 0, binary = 0;
 340   unsigned int retries;
 341   char *file, *md, *ptr;
 342
 343   if (SCM_UNLIKELY (!(scm_is_false (encoding) || scm_is_string (encoding))))
 344     scm_wrong_type_arg_msg (FUNC_NAME, 0, encoding,
 345                             "encoding to be string or false");
 346
 347   scm_dynwind_begin (0);
 348
 349   file = scm_to_locale_string (filename);
 350   scm_dynwind_free (file);
 351
 352   md = scm_to_locale_string (mode);
 353   scm_dynwind_free (md);
 354
 355   switch (*md)
 356     {
 357     case 'r':
 358       flags |= O_RDONLY;
 359       break;
 360     case 'w':
 361       flags |= O_WRONLY | O_CREAT | O_TRUNC;
 362       break;
 363     case 'a':
 364       flags |= O_WRONLY | O_CREAT | O_APPEND;
 365       break;
 366     default:
 367       scm_out_of_range (FUNC_NAME, mode);
 368     }
 369   ptr = md + 1;
 370   while (*ptr != '\0')
 371     {
 372       switch (*ptr)
 373         {
 374         case '+':
 375           flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
 376           break;
 377         case 'b':
 378           binary = 1;
 379 #if defined (O_BINARY)
 380           flags |= O_BINARY;
 381 #endif
 382           break;
 383         case '0':  /* unbuffered: handled later.  */
 384         case 'l':  /* line buffered: handled during output.  */
 385           break;
 386         default:
 387           scm_out_of_range (FUNC_NAME, mode);
 388         }
 389       ptr++;
 390     }
 391
 392   for (retries = 0, fdes = -1;
 393        fdes < 0 && retries < 2;
 394        retries++)
 395     {
 396       SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
 397       if (fdes == -1)
 398         {
 399           int en = errno;
 400
 401           if (en == EMFILE && retries == 0)
 402             /* Run the GC in case it collects open file ports that are no
 403                longer referenced.  */
 404             scm_i_gc (FUNC_NAME);
 405           else
 406             SCM_SYSERROR_MSG ("~A: ~S",
 407                               scm_cons (scm_strerror (scm_from_int (en)),
 408                                         scm_cons (filename, SCM_EOL)), en);
 409         }
 410     }
 411
 412   /* Create a port from this file descriptor.  The port's encoding is initially
 413      %default-port-encoding.  */
 414   port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode),
 415                              fport_canonicalize_filename (filename));
 416
 417   if (binary)
 418     {
 419       if (scm_is_true (encoding))
 420         scm_misc_error (FUNC_NAME,
 421                         "Encoding specified on a binary port",
 422                         scm_list_1 (encoding));
 423       if (scm_is_true (guess_encoding))
 424         scm_misc_error (FUNC_NAME,
 425                         "Request to guess encoding on a binary port",
 426                         SCM_EOL);
 427
 428       /* Use the binary-friendly ISO-8859-1 encoding. */
 429       scm_i_set_port_encoding_x (port, NULL);
 430     }
 431   else
 432     {
 433       char *enc = NULL;
 434
 435       if (scm_is_true (guess_encoding))
 436         {
 437           if (SCM_INPUT_PORT_P (port))
 438             enc = scm_i_scan_for_encoding (port);
 439           else
 440             scm_misc_error (FUNC_NAME,
 441                             "Request to guess encoding on an output-only port",
 442                             SCM_EOL);
 443         }
 444
 445       if (!enc && scm_is_true (encoding))
 446         {
 447           char *buf = scm_to_latin1_string (encoding);
 448           enc = scm_gc_strdup (buf, "encoding");
 449           free (buf);
 450         }
 451
 452       if (enc)
 453         scm_i_set_port_encoding_x (port, enc);
 454     }
 455
 456   scm_dynwind_end ();
 457
 458   return port;
 459 }
 460 #undef FUNC_NAME
 461
 462 SCM
 463 scm_open_file (SCM filename, SCM mode)
 464 {
 465   return scm_open_file_with_encoding (filename, mode, SCM_BOOL_F, SCM_BOOL_F);
 466 }
 467
 468 /* We can't define these using SCM_KEYWORD, because keywords have not
 469    yet been initialized when scm_init_fports is called.  */
 470 static SCM k_guess_encoding = SCM_UNDEFINED;
 471 static SCM k_encoding       = SCM_UNDEFINED;
 472
 473 SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1,
 474             (SCM filename, SCM mode, SCM keyword_args),
 475             "Open the file whose name is @var{filename}, and return a port\n"
 476             "representing that file.  The attributes of the port are\n"
 477             "determined by the @var{mode} string.  The way in which this is\n"
 478             "interpreted is similar to C stdio.  The first character must be\n"
 479             "one of the following:\n"
 480             "@table @samp\n"
 481             "@item r\n"
 482             "Open an existing file for input.\n"
 483             "@item w\n"
 484             "Open a file for output, creating it if it doesn't already exist\n"
 485             "or removing its contents if it does.\n"
 486             "@item a\n"
 487             "Open a file for output, creating it if it doesn't already\n"
 488             "exist.  All writes to the port will go to the end of the file.\n"
 489             "The \"append mode\" can be turned off while the port is in use\n"
 490             "@pxref{Ports and File Descriptors, fcntl}\n"
 491             "@end table\n"
 492             "The following additional characters can be appended:\n"
 493             "@table @samp\n"
 494             "@item b\n"
 495             "Open the underlying file in binary mode, if supported by the system.\n"
 496             "Also, open the file using the binary-compatible character encoding\n"
 497             "\"ISO-8859-1\", ignoring the default port encoding.\n"
 498             "@item +\n"
 499             "Open the port for both input and output.  E.g., @code{r+}: open\n"
 500             "an existing file for both input and output.\n"
 501             "@item 0\n"
 502             "Create an \"unbuffered\" port.  In this case input and output\n"
 503             "operations are passed directly to the underlying port\n"
 504             "implementation without additional buffering.  This is likely to\n"
 505             "slow down I/O operations.  The buffering mode can be changed\n"
 506             "while a port is in use @pxref{Ports and File Descriptors,\n"
 507             "setvbuf}\n"
 508             "@item l\n"
 509             "Add line-buffering to the port.  The port output buffer will be\n"
 510             "automatically flushed whenever a newline character is written.\n"
 511             "@end table\n"
 512             "In theory we could create read/write ports which were buffered\n"
 513             "in one direction only.  However this isn't included in the\n"
 514             "current interfaces.  If a file cannot be opened with the access\n"
 515             "requested, @code{open-file} throws an exception.")
 516 #define FUNC_NAME s_scm_i_open_file
 517 {
 518   SCM encoding = SCM_BOOL_F;
 519   SCM guess_encoding = SCM_BOOL_F;
 520
 521   scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
 522                                 k_guess_encoding, &guess_encoding,
 523                                 k_encoding, &encoding,
 524                                 SCM_UNDEFINED);
 525
 526   return scm_open_file_with_encoding (filename, mode,
 527                                       guess_encoding, encoding);
 528 }
 529 #undef FUNC_NAME
 530
 531 \f
 532 /* Building Guile ports from a file descriptor.  */
 533
 534 /* Build a Scheme port from an open file descriptor `fdes'.
 535    MODE indicates whether FILE is open for reading or writing; it uses
 536       the same notation as open-file's second argument.
 537    NAME is a string to be used as the port's filename.
 538 */
 539 SCM
 540 scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
 541 #define FUNC_NAME "scm_fdes_to_port"
 542 {
 543   SCM port;
 544   scm_t_fport *fp;
 545
 546   /* Test that fdes is valid.  */
 547 #ifdef F_GETFL
 548   int flags = fcntl (fdes, F_GETFL, 0);
 549   if (flags == -1)
 550     SCM_SYSERROR;
 551   flags &= O_ACCMODE;
 552   if (flags != O_RDWR
 553       && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
 554           || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
 555     {
 556       SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
 557     }
 558 #else
 559   /* If we don't have F_GETFL, as on mingw, at least we can test that
 560      it is a valid file descriptor.  */
 561   struct stat st;
 562   if (fstat (fdes, &st) != 0)
 563     SCM_SYSERROR;
 564 #endif
 565
 566   fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
 567                                                   "file port");
 568   fp->fdes = fdes;
 569
 570   port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp);
 571
 572   SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes);
 573
 574   if (mode_bits & SCM_BUF0)
 575     scm_fport_buffer_add (port, 0, 0);
 576   else
 577     scm_fport_buffer_add (port, -1, -1);
 578
 579   SCM_SET_FILENAME (port, name);
 580
 581   return port;
 582 }
 583 #undef FUNC_NAME
 584
 585 SCM
 586 scm_fdes_to_port (int fdes, char *mode, SCM name)
 587 {
 588   return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
 589 }
 590
 591 /* Return a lower bound on the number of bytes available for input.  */
 592 static int
 593 fport_input_waiting (SCM port)
 594 {
 595   int fdes = SCM_FSTREAM (port)->fdes;
 596
 597   struct pollfd pollfd = { fdes, POLLIN, 0 };
 598
 599   if (poll (&pollfd, 1, 0) < 0)
 600     scm_syserror ("fport_input_waiting");
 601
 602   return pollfd.revents & POLLIN ? 1 : 0;
 603 }
 604
 605
 606 \f
 607
 608 /* Revealed counts --- an oddity inherited from SCSH.  */
 609
 610 #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
 611
 612 static SCM revealed_ports = SCM_EOL;
 613 static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 614
 615 /* Find a port in the table and return its revealed count.
 616    Also used by the garbage collector.
 617  */
 618 int
 619 scm_revealed_count (SCM port)
 620 {
 621   int ret;
 622
 623   scm_i_pthread_mutex_lock (&revealed_lock);
 624   ret = SCM_REVEALED (port);
 625   scm_i_pthread_mutex_unlock (&revealed_lock);
 626
 627   return ret;
 628 }
 629
 630 SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
 631            (SCM port),
 632             "Return the revealed count for @var{port}.")
 633 #define FUNC_NAME s_scm_port_revealed
 634 {
 635   port = SCM_COERCE_OUTPORT (port);
 636   SCM_VALIDATE_OPFPORT (1, port);
 637   return scm_from_int (scm_revealed_count (port));
 638 }
 639 #undef FUNC_NAME
 640
 641 /* Set the revealed count for a port.  */
 642 SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
 643            (SCM port, SCM rcount),
 644             "Sets the revealed count for a port to a given value.\n"
 645             "The return value is unspecified.")
 646 #define FUNC_NAME s_scm_set_port_revealed_x
 647 {
 648   int r, prev;
 649
 650   port = SCM_COERCE_OUTPORT (port);
 651   SCM_VALIDATE_OPFPORT (1, port);
 652
 653   r = scm_to_int (rcount);
 654
 655   scm_i_pthread_mutex_lock (&revealed_lock);
 656
 657   prev = SCM_REVEALED (port);
 658   SCM_REVEALED (port) = r;
 659
 660   if (r && !prev)
 661     revealed_ports = scm_cons (port, revealed_ports);
 662   else if (prev && !r)
 663     revealed_ports = scm_delq_x (port, revealed_ports);
 664
 665   scm_i_pthread_mutex_unlock (&revealed_lock);
 666
 667   return SCM_UNSPECIFIED;
 668 }
 669 #undef FUNC_NAME
 670
 671 /* Set the revealed count for a port.  */
 672 SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
 673            (SCM port, SCM addend),
 674             "Add @var{addend} to the revealed count of @var{port}.\n"
 675             "The return value is unspecified.")
 676 #define FUNC_NAME s_scm_adjust_port_revealed_x
 677 {
 678   int a;
 679
 680   port = SCM_COERCE_OUTPORT (port);
 681   SCM_VALIDATE_OPFPORT (1, port);
 682
 683   a = scm_to_int (addend);
 684   if (!a)
 685     return SCM_UNSPECIFIED;
 686
 687   scm_i_pthread_mutex_lock (&revealed_lock);
 688
 689   SCM_REVEALED (port) += a;
 690   if (SCM_REVEALED (port) == a)
 691     revealed_ports = scm_cons (port, revealed_ports);
 692   else if (!SCM_REVEALED (port))
 693     revealed_ports = scm_delq_x (port, revealed_ports);
 694
 695   scm_i_pthread_mutex_unlock (&revealed_lock);
 696
 697   return SCM_UNSPECIFIED;
 698 }
 699 #undef FUNC_NAME
 700
 701
 702 \f
 703 static int
 704 fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 705 {
 706   scm_puts_unlocked ("#<", port);
 707   scm_print_port_mode (exp, port);
 708   if (SCM_OPFPORTP (exp))
 709     {
 710       int fdes;
 711       SCM name = SCM_FILENAME (exp);
 712       if (scm_is_string (name) || scm_is_symbol (name))
 713         scm_display (name, port);
 714       else
 715         scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 716       scm_putc_unlocked (' ', port);
 717       fdes = (SCM_FSTREAM (exp))->fdes;
 718
 719 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
 720       if (isatty (fdes))
 721         scm_display (scm_ttyname (exp), port);
 722       else
 723 #endif /* HAVE_TTYNAME */
 724         scm_intprint (fdes, 10, port);
 725     }
 726   else
 727     {
 728       scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 729       scm_putc_unlocked (' ', port);
 730       scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
 731     }
 732   scm_putc_unlocked ('>', port);
 733   return 1;
 734 }
 735
 736 static void fport_flush (SCM port);
 737
 738 /* fill a port's read-buffer with a single read.  returns the first
 739    char or EOF if end of file.  */
 740 static scm_t_wchar
 741 fport_fill_input (SCM port)
 742 {
 743   long count;
 744   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 745   scm_t_fport *fp = SCM_FSTREAM (port);
 746
 747   SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
 748   if (count == -1)
 749     scm_syserror ("fport_fill_input");
 750   if (count == 0)
 751     return (scm_t_wchar) EOF;
 752   else
 753     {
 754       pt->read_pos = pt->read_buf;
 755       pt->read_end = pt->read_buf + count;
 756       return *pt->read_buf;
 757     }
 758 }
 759
 760 static scm_t_off
 761 fport_seek (SCM port, scm_t_off offset, int whence)
 762 {
 763   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 764   scm_t_fport *fp = SCM_FSTREAM (port);
 765   off_t_or_off64_t rv;
 766   off_t_or_off64_t result;
 767
 768   if (pt->rw_active == SCM_PORT_WRITE)
 769     {
 770       if (offset != 0 || whence != SEEK_CUR)
 771         {
 772           fport_flush (port);
 773           result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 774         }
 775       else
 776         {
 777           /* read current position without disturbing the buffer.  */
 778           rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 779           result = rv + (pt->write_pos - pt->write_buf);
 780         }
 781     }
 782   else if (pt->rw_active == SCM_PORT_READ)
 783     {
 784       if (offset != 0 || whence != SEEK_CUR)
 785         {
 786           /* could expand to avoid a second seek.  */
 787           scm_end_input_unlocked (port);
 788           result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 789         }
 790       else
 791         {
 792           /* read current position without disturbing the buffer
 793              (particularly the unread-char buffer).  */
 794           rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 795           result = rv - (pt->read_end - pt->read_pos);
 796
 797           if (pt->read_buf == pt->putback_buf)
 798             result -= pt->saved_read_end - pt->saved_read_pos;
 799         }
 800     }
 801   else /* SCM_PORT_NEITHER */
 802     {
 803       result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 804     }
 805
 806   if (rv == -1)
 807     scm_syserror ("fport_seek");
 808
 809   return result;
 810 }
 811
 812 static void
 813 fport_truncate (SCM port, scm_t_off length)
 814 {
 815   scm_t_fport *fp = SCM_FSTREAM (port);
 816
 817   if (ftruncate (fp->fdes, length) == -1)
 818     scm_syserror ("ftruncate");
 819 }
 820
 821 static void
 822 fport_write (SCM port, const void *data, size_t size)
 823 #define FUNC_NAME "fport_write"
 824 {
 825   /* this procedure tries to minimize the number of writes/flushes.  */
 826   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 827
 828   if (pt->write_buf == &pt->shortbuf
 829       || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
 830     {
 831       /* Unbuffered port, or port with empty buffer and data won't fit in
 832          buffer.  */
 833       if (full_write (SCM_FPORT_FDES (port), data, size) < size)
 834         SCM_SYSERROR;
 835
 836       return;
 837     }
 838
 839   {
 840     scm_t_off space = pt->write_end - pt->write_pos;
 841
 842     if (size <= space)
 843       {
 844         /* data fits in buffer.  */
 845         memcpy (pt->write_pos, data, size);
 846         pt->write_pos += size;
 847         if (pt->write_pos == pt->write_end)
 848           {
 849             fport_flush (port);
 850             /* we can skip the line-buffering check if nothing's buffered. */
 851             return;
 852           }
 853       }
 854     else
 855       {
 856         memcpy (pt->write_pos, data, space);
 857         pt->write_pos = pt->write_end;
 858         fport_flush (port);
 859         {
 860           const void *ptr = ((const char *) data) + space;
 861           size_t remaining = size - space;
 862
 863           if (size >= pt->write_buf_size)
 864             {
 865               if (full_write (SCM_FPORT_FDES (port), ptr, remaining)
 866                   < remaining)
 867                 SCM_SYSERROR;
 868               return;
 869             }
 870           else
 871             {
 872               memcpy (pt->write_pos, ptr, remaining);
 873               pt->write_pos += remaining;
 874             }
 875         }
 876       }
 877
 878     /* handle line buffering.  */
 879     if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
 880       fport_flush (port);
 881   }
 882 }
 883 #undef FUNC_NAME
 884
 885 static void
 886 fport_flush (SCM port)
 887 {
 888   size_t written;
 889   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 890   scm_t_fport *fp = SCM_FSTREAM (port);
 891   size_t count = pt->write_pos - pt->write_buf;
 892
 893   written = full_write (fp->fdes, pt->write_buf, count);
 894   if (written < count)
 895     scm_syserror ("scm_flush");
 896
 897   pt->write_pos = pt->write_buf;
 898   pt->rw_active = SCM_PORT_NEITHER;
 899 }
 900
 901 /* clear the read buffer and adjust the file position for unread bytes. */
 902 static void
 903 fport_end_input (SCM port, int offset)
 904 {
 905   scm_t_fport *fp = SCM_FSTREAM (port);
 906   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 907
 908   offset += pt->read_end - pt->read_pos;
 909
 910   if (offset > 0)
 911     {
 912       pt->read_pos = pt->read_end;
 913       /* will throw error if unread-char used at beginning of file
 914          then attempting to write.  seems correct.  */
 915       if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
 916         scm_syserror ("fport_end_input");
 917     }
 918   pt->rw_active = SCM_PORT_NEITHER;
 919 }
 920
 921 static void
 922 close_the_fd (void *data)
 923 {
 924   scm_t_fport *fp = data;
 925
 926   close (fp->fdes);
 927   /* There's already one exception.  That's probably enough!  */
 928   errno = 0;
 929 }
 930
 931 static int
 932 fport_close (SCM port)
 933 {
 934   scm_t_fport *fp = SCM_FSTREAM (port);
 935   int rv;
 936
 937   scm_dynwind_begin (0);
 938   scm_dynwind_unwind_handler (close_the_fd, fp, 0);
 939   fport_flush (port);
 940   scm_dynwind_end ();
 941
 942   scm_port_non_buffer (SCM_PTAB_ENTRY (port));
 943
 944   rv = close (fp->fdes);
 945   if (rv)
 946     /* It's not useful to retry after EINTR, as the file descriptor is
 947        in an undefined state.  See http://lwn.net/Articles/365294/.
 948        Instead just throw an error if close fails, trusting that the fd
 949        was cleaned up.  */
 950     scm_syserror ("fport_close");
 951
 952   return 0;
 953 }
 954
 955 static size_t
 956 fport_free (SCM port)
 957 {
 958   fport_close (port);
 959   return 0;
 960 }
 961
 962 static scm_t_bits
 963 scm_make_fptob ()
 964 {
 965   scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);
 966
 967   scm_set_port_free            (tc, fport_free);
 968   scm_set_port_print           (tc, fport_print);
 969   scm_set_port_flush           (tc, fport_flush);
 970   scm_set_port_end_input       (tc, fport_end_input);
 971   scm_set_port_close           (tc, fport_close);
 972   scm_set_port_seek            (tc, fport_seek);
 973   scm_set_port_truncate        (tc, fport_truncate);
 974   scm_set_port_input_waiting   (tc, fport_input_waiting);
 975
 976   return tc;
 977 }
 978
 979 /* We can't initialize the keywords from 'scm_init_fports', because
 980    keywords haven't yet been initialized at that point.  */
 981 void
 982 scm_init_fports_keywords ()
 983 {
 984   k_guess_encoding = scm_from_latin1_keyword ("guess-encoding");
 985   k_encoding       = scm_from_latin1_keyword ("encoding");
 986 }
 987
 988 void
 989 scm_init_fports ()
 990 {
 991   scm_tc16_fport = scm_make_fptob ();
 992
 993   scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
 994   scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
 995   scm_c_define ("_IONBF", scm_from_int (_IONBF));
 996
 997   sys_file_port_name_canonicalization = scm_make_fluid ();
 998   scm_c_define ("%file-port-name-canonicalization",
 999                 sys_file_port_name_canonicalization);
1000
1001 #include "libguile/fports.x"
1002 }
1003
1004 /*
1005   Local Variables:
1006   c-file-style: "gnu"
1007   End:
1008 */