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