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_port_internal *pti;
 163
 164   port = SCM_COERCE_OUTPORT (port);
 165
 166   SCM_VALIDATE_OPENPORT (1, port);
 167   pti = SCM_PORT_GET_INTERNAL (port);
 168
 169   if (pti->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 (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   pti->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_DEFINE (scm_i_open_file, "open-file", 2, 0, 1,
 480             (SCM filename, SCM mode, SCM keyword_args),
 481             "Open the file whose name is @var{filename}, and return a port\n"
 482             "representing that file.  The attributes of the port are\n"
 483             "determined by the @var{mode} string.  The way in which this is\n"
 484             "interpreted is similar to C stdio.  The first character must be\n"
 485             "one of the following:\n"
 486             "@table @samp\n"
 487             "@item r\n"
 488             "Open an existing file for input.\n"
 489             "@item w\n"
 490             "Open a file for output, creating it if it doesn't already exist\n"
 491             "or removing its contents if it does.\n"
 492             "@item a\n"
 493             "Open a file for output, creating it if it doesn't already\n"
 494             "exist.  All writes to the port will go to the end of the file.\n"
 495             "The \"append mode\" can be turned off while the port is in use\n"
 496             "@pxref{Ports and File Descriptors, fcntl}\n"
 497             "@end table\n"
 498             "The following additional characters can be appended:\n"
 499             "@table @samp\n"
 500             "@item b\n"
 501             "Open the underlying file in binary mode, if supported by the system.\n"
 502             "Also, open the file using the binary-compatible character encoding\n"
 503             "\"ISO-8859-1\", ignoring the default port encoding.\n"
 504             "@item +\n"
 505             "Open the port for both input and output.  E.g., @code{r+}: open\n"
 506             "an existing file for both input and output.\n"
 507             "@item 0\n"
 508             "Create an \"unbuffered\" port.  In this case input and output\n"
 509             "operations are passed directly to the underlying port\n"
 510             "implementation without additional buffering.  This is likely to\n"
 511             "slow down I/O operations.  The buffering mode can be changed\n"
 512             "while a port is in use @pxref{Ports and File Descriptors,\n"
 513             "setvbuf}\n"
 514             "@item l\n"
 515             "Add line-buffering to the port.  The port output buffer will be\n"
 516             "automatically flushed whenever a newline character is written.\n"
 517             "@end table\n"
 518             "In theory we could create read/write ports which were buffered\n"
 519             "in one direction only.  However this isn't included in the\n"
 520             "current interfaces.  If a file cannot be opened with the access\n"
 521             "requested, @code{open-file} throws an exception.")
 522 #define FUNC_NAME s_scm_i_open_file
 523 {
 524   SCM encoding = SCM_BOOL_F;
 525   SCM guess_encoding = SCM_BOOL_F;
 526
 527   scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
 528                                 k_guess_encoding, &guess_encoding,
 529                                 k_encoding, &encoding,
 530                                 SCM_UNDEFINED);
 531
 532   return scm_open_file_with_encoding (filename, mode,
 533                                       guess_encoding, encoding);
 534 }
 535 #undef FUNC_NAME
 536
 537 \f
 538 /* Building Guile ports from a file descriptor.  */
 539
 540 /* Build a Scheme port from an open file descriptor `fdes'.
 541    MODE indicates whether FILE is open for reading or writing; it uses
 542       the same notation as open-file's second argument.
 543    NAME is a string to be used as the port's filename.
 544 */
 545 SCM
 546 scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
 547 #define FUNC_NAME "scm_fdes_to_port"
 548 {
 549   SCM port;
 550   scm_t_port *pt;
 551   scm_t_port_internal *pti;
 552
 553   /* Test that fdes is valid.  */
 554 #ifdef F_GETFL
 555   int flags = fcntl (fdes, F_GETFL, 0);
 556   if (flags == -1)
 557     SCM_SYSERROR;
 558   flags &= O_ACCMODE;
 559   if (flags != O_RDWR
 560       && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
 561           || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
 562     {
 563       SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
 564     }
 565 #else
 566   /* If we don't have F_GETFL, as on mingw, at least we can test that
 567      it is a valid file descriptor.  */
 568   struct stat st;
 569   if (fstat (fdes, &st) != 0)
 570     SCM_SYSERROR;
 571 #endif
 572
 573   scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
 574
 575   port = scm_new_port_table_entry (scm_tc16_fport);
 576   SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
 577   pt = SCM_PTAB_ENTRY (port);
 578
 579   /* File ports support 'setvbuf'.  */
 580   pti = SCM_PORT_GET_INTERNAL (port);
 581   pti->setvbuf = scm_fport_buffer_add;
 582
 583   {
 584     scm_t_fport *fp
 585       = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
 586                                                    "file port");
 587
 588     fp->fdes = fdes;
 589     pt->rw_random = SCM_FDES_RANDOM_P (fdes);
 590     SCM_SETSTREAM (port, fp);
 591     if (mode_bits & SCM_BUF0)
 592       scm_fport_buffer_add (port, 0, 0);
 593     else
 594       scm_fport_buffer_add (port, -1, -1);
 595   }
 596   SCM_SET_FILENAME (port, name);
 597   scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
 598   return port;
 599 }
 600 #undef FUNC_NAME
 601
 602 SCM
 603 scm_fdes_to_port (int fdes, char *mode, SCM name)
 604 {
 605   return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
 606 }
 607
 608 /* Return a lower bound on the number of bytes available for input.  */
 609 static int
 610 fport_input_waiting (SCM port)
 611 {
 612   int fdes = SCM_FSTREAM (port)->fdes;
 613
 614   struct pollfd pollfd = { fdes, POLLIN, 0 };
 615
 616   if (poll (&pollfd, 1, 0) < 0)
 617     scm_syserror ("fport_input_waiting");
 618
 619   return pollfd.revents & POLLIN ? 1 : 0;
 620 }
 621
 622 \f
 623 static int
 624 fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 625 {
 626   scm_puts ("#<", port);
 627   scm_print_port_mode (exp, port);
 628   if (SCM_OPFPORTP (exp))
 629     {
 630       int fdes;
 631       SCM name = SCM_FILENAME (exp);
 632       if (scm_is_string (name) || scm_is_symbol (name))
 633         scm_display (name, port);
 634       else
 635         scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 636       scm_putc (' ', port);
 637       fdes = (SCM_FSTREAM (exp))->fdes;
 638
 639 #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
 640       if (isatty (fdes))
 641         scm_display (scm_ttyname (exp), port);
 642       else
 643 #endif /* HAVE_TTYNAME */
 644         scm_intprint (fdes, 10, port);
 645     }
 646   else
 647     {
 648       scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
 649       scm_putc (' ', port);
 650       scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
 651     }
 652   scm_putc ('>', port);
 653   return 1;
 654 }
 655
 656 static void fport_flush (SCM port);
 657
 658 /* fill a port's read-buffer with a single read.  returns the first
 659    char or EOF if end of file.  */
 660 static scm_t_wchar
 661 fport_fill_input (SCM port)
 662 {
 663   long count;
 664   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 665   scm_t_fport *fp = SCM_FSTREAM (port);
 666
 667   SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
 668   if (count == -1)
 669     scm_syserror ("fport_fill_input");
 670   if (count == 0)
 671     return (scm_t_wchar) EOF;
 672   else
 673     {
 674       pt->read_pos = pt->read_buf;
 675       pt->read_end = pt->read_buf + count;
 676       return *pt->read_buf;
 677     }
 678 }
 679
 680 static scm_t_off
 681 fport_seek (SCM port, scm_t_off offset, int whence)
 682 {
 683   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 684   scm_t_fport *fp = SCM_FSTREAM (port);
 685   off_t_or_off64_t rv;
 686   off_t_or_off64_t result;
 687
 688   if (pt->rw_active == SCM_PORT_WRITE)
 689     {
 690       if (offset != 0 || whence != SEEK_CUR)
 691         {
 692           fport_flush (port);
 693           result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 694         }
 695       else
 696         {
 697           /* read current position without disturbing the buffer.  */
 698           rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 699           result = rv + (pt->write_pos - pt->write_buf);
 700         }
 701     }
 702   else if (pt->rw_active == SCM_PORT_READ)
 703     {
 704       if (offset != 0 || whence != SEEK_CUR)
 705         {
 706           /* could expand to avoid a second seek.  */
 707           scm_end_input (port);
 708           result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 709         }
 710       else
 711         {
 712           /* read current position without disturbing the buffer
 713              (particularly the unread-char buffer).  */
 714           rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 715           result = rv - (pt->read_end - pt->read_pos);
 716
 717           if (pt->read_buf == pt->putback_buf)
 718             result -= pt->saved_read_end - pt->saved_read_pos;
 719         }
 720     }
 721   else /* SCM_PORT_NEITHER */
 722     {
 723       result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
 724     }
 725
 726   if (rv == -1)
 727     scm_syserror ("fport_seek");
 728
 729   return result;
 730 }
 731
 732 static void
 733 fport_truncate (SCM port, scm_t_off length)
 734 {
 735   scm_t_fport *fp = SCM_FSTREAM (port);
 736
 737   if (ftruncate (fp->fdes, length) == -1)
 738     scm_syserror ("ftruncate");
 739 }
 740
 741 static void
 742 fport_write (SCM port, const void *data, size_t size)
 743 #define FUNC_NAME "fport_write"
 744 {
 745   /* this procedure tries to minimize the number of writes/flushes.  */
 746   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 747
 748   if (pt->write_buf == &pt->shortbuf
 749       || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
 750     {
 751       /* Unbuffered port, or port with empty buffer and data won't fit in
 752          buffer.  */
 753       if (full_write (SCM_FPORT_FDES (port), data, size) < size)
 754         SCM_SYSERROR;
 755
 756       return;
 757     }
 758
 759   {
 760     scm_t_off space = pt->write_end - pt->write_pos;
 761
 762     if (size <= space)
 763       {
 764         /* data fits in buffer.  */
 765         memcpy (pt->write_pos, data, size);
 766         pt->write_pos += size;
 767         if (pt->write_pos == pt->write_end)
 768           {
 769             fport_flush (port);
 770             /* we can skip the line-buffering check if nothing's buffered. */
 771             return;
 772           }
 773       }
 774     else
 775       {
 776         memcpy (pt->write_pos, data, space);
 777         pt->write_pos = pt->write_end;
 778         fport_flush (port);
 779         {
 780           const void *ptr = ((const char *) data) + space;
 781           size_t remaining = size - space;
 782
 783           if (size >= pt->write_buf_size)
 784             {
 785               if (full_write (SCM_FPORT_FDES (port), ptr, remaining)
 786                   < remaining)
 787                 SCM_SYSERROR;
 788               return;
 789             }
 790           else
 791             {
 792               memcpy (pt->write_pos, ptr, remaining);
 793               pt->write_pos += remaining;
 794             }
 795         }
 796       }
 797
 798     /* handle line buffering.  */
 799     if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
 800       fport_flush (port);
 801   }
 802 }
 803 #undef FUNC_NAME
 804
 805 static void
 806 fport_flush (SCM port)
 807 {
 808   size_t written;
 809   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 810   scm_t_fport *fp = SCM_FSTREAM (port);
 811   size_t count = pt->write_pos - pt->write_buf;
 812
 813   written = full_write (fp->fdes, pt->write_buf, count);
 814   if (written < count)
 815     scm_syserror ("scm_flush");
 816
 817   pt->write_pos = pt->write_buf;
 818   pt->rw_active = SCM_PORT_NEITHER;
 819 }
 820
 821 /* clear the read buffer and adjust the file position for unread bytes. */
 822 static void
 823 fport_end_input (SCM port, int offset)
 824 {
 825   scm_t_fport *fp = SCM_FSTREAM (port);
 826   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 827
 828   offset += pt->read_end - pt->read_pos;
 829
 830   if (offset > 0)
 831     {
 832       pt->read_pos = pt->read_end;
 833       /* will throw error if unread-char used at beginning of file
 834          then attempting to write.  seems correct.  */
 835       if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
 836         scm_syserror ("fport_end_input");
 837     }
 838   pt->rw_active = SCM_PORT_NEITHER;
 839 }
 840
 841 static int
 842 fport_close (SCM port)
 843 {
 844   scm_t_fport *fp = SCM_FSTREAM (port);
 845   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 846   int rv;
 847
 848   fport_flush (port);
 849   SCM_SYSCALL (rv = close (fp->fdes));
 850   if (rv == -1 && errno != EBADF)
 851     {
 852       if (scm_gc_running_p)
 853         /* silently ignore the error.  scm_error would abort if we
 854            called it now.  */
 855         ;
 856       else
 857         scm_syserror ("fport_close");
 858     }
 859   if (pt->read_buf == pt->putback_buf)
 860     pt->read_buf = pt->saved_read_buf;
 861   if (pt->read_buf != &pt->shortbuf)
 862     scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
 863   if (pt->write_buf != &pt->shortbuf)
 864     scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
 865   scm_gc_free (fp, sizeof (*fp), "file port");
 866   return rv;
 867 }
 868
 869 static size_t
 870 fport_free (SCM port)
 871 {
 872   fport_close (port);
 873   return 0;
 874 }
 875
 876 static scm_t_bits
 877 scm_make_fptob ()
 878 {
 879   scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);
 880
 881   scm_set_port_free            (tc, fport_free);
 882   scm_set_port_print           (tc, fport_print);
 883   scm_set_port_flush           (tc, fport_flush);
 884   scm_set_port_end_input       (tc, fport_end_input);
 885   scm_set_port_close           (tc, fport_close);
 886   scm_set_port_seek            (tc, fport_seek);
 887   scm_set_port_truncate        (tc, fport_truncate);
 888   scm_set_port_input_waiting   (tc, fport_input_waiting);
 889
 890   return tc;
 891 }
 892
 893 /* We can't initialize the keywords from 'scm_init_fports', because
 894    keywords haven't yet been initialized at that point.  */
 895 void
 896 scm_init_fports_keywords ()
 897 {
 898   k_guess_encoding = scm_from_latin1_keyword ("guess-encoding");
 899   k_encoding       = scm_from_latin1_keyword ("encoding");
 900 }
 901
 902 void
 903 scm_init_fports ()
 904 {
 905   scm_tc16_fport = scm_make_fptob ();
 906
 907   scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
 908   scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
 909   scm_c_define ("_IONBF", scm_from_int (_IONBF));
 910
 911   sys_file_port_name_canonicalization = scm_make_fluid ();
 912   scm_c_define ("%file-port-name-canonicalization",
 913                 sys_file_port_name_canonicalization);
 914
 915 #include "libguile/fports.x"
 916 }
 917
 918 /*
 919   Local Variables:
 920   c-file-style: "gnu"
 921   End:
 922 */