libguile/fports.c

   1 /*      Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "markers.h"
  46
  47 #include "fports.h"
  48
  49 #ifdef HAVE_STRING_H
  50 #include <string.h>
  51 #endif
  52 #ifdef HAVE_UNISTD_H
  53 #include <unistd.h>
  54 #else
  55 scm_sizet fwrite ();
  56 #endif
  57
  58 /* {Ports - file ports}
  59  *
  60  */
  61
  62 /* should be called with SCM_DEFER_INTS active */
  63
  64 SCM
  65 scm_setbuf0 (port)
  66      SCM port;
  67 {
  68   /* NOSETBUF was provided by scm to allow unbuffered ports to be
  69      avoided on systems where ungetc didn't work correctly.  See
  70      comment in unif.c, which seems to be the only place where it
  71      could still be a problem.  */
  72 #ifndef NOSETBUF
  73   /*  SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0);); */
  74   SCM_SYSCALL (setvbuf ((FILE *)SCM_STREAM (port), 0, _IONBF, 0););
  75 #endif
  76   return SCM_UNSPECIFIED;
  77 }
  78
  79 SCM_PROC (s_setvbuf, "setvbuf", 2, 1, 0, scm_setvbuf);
  80 SCM
  81 scm_setvbuf (SCM port, SCM mode, SCM size)
  82 {
  83   int rv;
  84   int cmode, csize;
  85
  86   port = SCM_COERCE_OUTPORT (port);
  87
  88   SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG1, s_setvbuf);
  89   SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_setvbuf);
  90   if (SCM_UNBNDP (size))
  91     csize = 0;
  92   else
  93     {
  94       SCM_ASSERT (SCM_INUMP (size), size, SCM_ARG3, s_setvbuf);
  95       csize = SCM_INUM (size);
  96     }
  97   cmode = SCM_INUM (mode);
  98   if (csize == 0 && cmode == _IOFBF)
  99     cmode = _IONBF;
 100   SCM_DEFER_INTS;
 101   SCM_SYSCALL (rv = setvbuf ((FILE *)SCM_STREAM (port), 0, cmode, csize));
 102   if (rv < 0)
 103     scm_syserror (s_setvbuf);
 104   if (cmode == _IONBF)
 105     SCM_SETCAR (port, SCM_CAR (port) | SCM_BUF0);
 106   else
 107     SCM_SETCAR (port, (SCM_CAR (port) & ~SCM_BUF0));
 108   SCM_ALLOW_INTS;
 109   return SCM_UNSPECIFIED;
 110 }
 111
 112 #ifdef FD_SETTER
 113 #define SET_FILE_FD_FIELD(F,D) ((F)->FD_SETTER = (D))
 114 #endif
 115
 116 void
 117 scm_setfileno (fs, fd)
 118      FILE *fs;
 119      int fd;
 120 {
 121 #ifdef SET_FILE_FD_FIELD
 122   SET_FILE_FD_FIELD(fs, fd);
 123 #else
 124   scm_misc_error ("scm_setfileno", "Not fully implemented on this platform",
 125                   SCM_EOL);
 126 #endif
 127 }
 128
 129 /* Move ports with the specified file descriptor to new descriptors,
 130  * reseting the revealed count to 0.
 131  * Should be called with SCM_DEFER_INTS active.
 132  */
 133
 134 void
 135 scm_evict_ports (fd)
 136      int fd;
 137 {
 138   int i;
 139
 140   for (i = 0; i < scm_port_table_size; i++)
 141     {
 142       if (SCM_FPORTP (scm_port_table[i]->port)
 143           && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd)
 144         {
 145           scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd));
 146           scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0));
 147         }
 148     }
 149 }
 150
 151 /* scm_open_file
 152  * Return a new port open on a given file.
 153  *
 154  * The mode string must match the pattern: [rwa+]** which
 155  * is interpreted in the usual unix way.
 156  *
 157  * Return the new port.
 158  */
 159 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 160
 161 SCM
 162 scm_open_file (filename, modes)
 163      SCM filename;
 164      SCM modes;
 165 {
 166   SCM port;
 167   FILE *f;
 168   char *file;
 169   char *mode;
 170
 171   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 172   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 173   if (SCM_SUBSTRP (filename))
 174     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 175   if (SCM_SUBSTRP (modes))
 176     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 177
 178   file = SCM_ROCHARS (filename);
 179   mode = SCM_ROCHARS (modes);
 180
 181   SCM_NEWCELL (port);
 182   SCM_DEFER_INTS;
 183   SCM_SYSCALL (f = fopen (file, mode));
 184   if (!f)
 185     {
 186       int en = errno;
 187
 188       scm_syserror_msg (s_open_file, "%s: %S",
 189                         scm_listify (scm_makfrom0str (strerror (errno)),
 190                                      filename,
 191                                      SCM_UNDEFINED),
 192                         en);
 193     }
 194   else
 195     {
 196       struct scm_port_table * pt;
 197
 198       pt = scm_add_to_port_table (port);
 199       SCM_SETPTAB_ENTRY (port, pt);
 200       SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode));
 201       SCM_SETSTREAM (port, (SCM) f);
 202       if (SCM_BUF0 & SCM_CAR (port))
 203         scm_setbuf0 (port);
 204       SCM_PTAB_ENTRY (port)->file_name = filename;
 205     }
 206   SCM_ALLOW_INTS;
 207   return port;
 208 }
 209
 210
 211 /* Build a Scheme port from an open stdio port, FILE.
 212    MODE indicates whether FILE is open for reading or writing; it uses
 213       the same notation as open-file's second argument.
 214    If NAME is non-zero, use it as the port's filename.
 215
 216    scm_stdio_to_port sets the revealed count for FILE's file
 217    descriptor to 1, so that FILE won't be closed when the port object
 218    is GC'd.  */
 219 SCM
 220 scm_stdio_to_port (file, mode, name)
 221      FILE *file;
 222      char *mode;
 223      char *name;
 224 {
 225   long mode_bits = scm_mode_bits (mode);
 226   SCM port;
 227   struct scm_port_table * pt;
 228
 229   SCM_NEWCELL (port);
 230   SCM_DEFER_INTS;
 231   {
 232     pt = scm_add_to_port_table (port);
 233     SCM_SETPTAB_ENTRY (port, pt);
 234     SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
 235     SCM_SETSTREAM (port, (SCM) file);
 236     if (SCM_BUF0 & SCM_CAR (port))
 237       scm_setbuf0 (port);
 238     SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
 239   }
 240   SCM_ALLOW_INTS;
 241   scm_set_port_revealed_x (port, SCM_MAKINUM (1));
 242   return port;
 243 }
 244
 245
 246
 247 static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 248
 249 static int
 250 prinfport (exp, port, pstate)
 251      SCM exp;
 252      SCM port;
 253      scm_print_state *pstate;
 254 {
 255   SCM name;
 256   char * c;
 257   if (SCM_CLOSEDP (exp))
 258     {
 259       c = "file";
 260     }
 261   else
 262     {
 263       name = SCM_PTAB_ENTRY (exp)->file_name;
 264       if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 265         c = SCM_ROCHARS (name);
 266       else
 267         c = "file";
 268     }
 269
 270   scm_prinport (exp, port, c);
 271   return !0;
 272 }
 273
 274
 275
 276 static int scm_fgetc SCM_P ((FILE * s));
 277
 278 static int
 279 scm_fgetc (s)
 280      FILE * s;
 281 {
 282   if (feof (s))
 283     return EOF;
 284   else
 285     return fgetc (s);
 286 }
 287
 288 /*
 289  * The fgets method must take a port as its argument, rather than
 290  * the underlying file handle.  The reason is that we also provide
 291  * a generic fgets method for ports which can't use fgets(3) (e.g.
 292  * string ports).  This generic method calls the port's own
 293  * fgetc method.  In order for it to know how to get that method,
 294  * we must pass the original Scheme port object.
 295  */
 296
 297 static char * scm_fgets SCM_P ((SCM port, int *len));
 298
 299 static char *
 300 scm_fgets (port, len)
 301      SCM port;
 302      int *len;
 303 {
 304   FILE *f;
 305
 306   char *buf   = NULL;
 307   char *p;              /* pointer to current buffer position */
 308   int   limit = 80;     /* current size of buffer */
 309
 310   f = (FILE *) SCM_STREAM (port);
 311   if (feof (f))
 312     return NULL;
 313
 314   buf = (char *) malloc (limit * sizeof(char));
 315   *len = 0;
 316
 317   /* If a char has been pushed onto the port with scm_ungetc,
 318      read that first. */
 319   if (SCM_CRDYP (port))
 320     {
 321       buf[*len] = SCM_CGETUN (port);
 322       SCM_CLRDY (port);
 323       if (buf[(*len)++] == '\n')
 324         {
 325           buf[*len] = '\0';
 326           return buf;
 327         }
 328     }
 329
 330   while (1)
 331     {
 332       int chunk_size = limit - *len;
 333       long int numread, pos;
 334
 335       p = buf + *len;
 336
 337       /* We must use ftell to figure out how many characters were read.
 338          If there are null characters near the end of file, and no
 339          terminating newline, there is no other way to tell the difference
 340          between an embedded null and the string-terminating null. */
 341
 342       pos = ftell (f);
 343       if (fgets (p, chunk_size, f) == NULL) {
 344         if (*len)
 345           return buf;
 346         free (buf);
 347         return NULL;
 348       }
 349       numread = ftell (f) - pos;
 350       *len += numread;
 351
 352       if (numread < chunk_size - 1 || buf[limit-2] == '\n')
 353         return buf;
 354
 355       buf = (char *) realloc (buf, sizeof(char) * limit * 2);
 356       limit *= 2;
 357     }
 358 }
 359
 360 #ifdef vms
 361
 362 static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
 363
 364 static scm_sizet
 365 pwrite (ptr, size, nitems, port)
 366      char *ptr;
 367      scm_sizet size, nitems;
 368      FILE *port;
 369 {
 370   scm_sizet len = size * nitems;
 371   scm_sizet i = 0;
 372   for (; i < len; i++)
 373     putc (ptr[i], port);
 374   return len;
 375 }
 376
 377 #define ffwrite pwrite
 378 #else
 379 #define ffwrite fwrite
 380 #endif
 381
 382 \f
 383 /* This otherwise pointless code helps some poor
 384  * crippled C compilers cope with life.
 385  */
 386
 387 static int local_fclose SCM_P ((FILE *fp));
 388
 389 static int
 390 local_fclose (fp)
 391      FILE * fp;
 392 {
 393   return fclose (fp);
 394 }
 395
 396 static int local_fflush SCM_P ((FILE *fp));
 397
 398 static int
 399 local_fflush (fp)
 400      FILE * fp;
 401 {
 402   return fflush (fp);
 403 }
 404
 405 static int local_fputc SCM_P ((int c, FILE *fp));
 406
 407 static int
 408 local_fputc (c, fp)
 409      int c;
 410      FILE * fp;
 411 {
 412   return fputc (c, fp);
 413 }
 414
 415 static int local_fputs SCM_P ((char *s, FILE *fp));
 416
 417 static int
 418 local_fputs (s, fp)
 419      char * s;
 420      FILE * fp;
 421 {
 422   return fputs (s, fp);
 423 }
 424
 425 static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp));
 426
 427 static scm_sizet
 428 local_ffwrite (ptr, size, nitems, fp)
 429      void * ptr;
 430      int size;
 431      int nitems;
 432      FILE * fp;
 433 {
 434   return ffwrite (ptr, size, nitems, fp);
 435 }
 436
 437 static int
 438 print_pipe_port (SCM exp, SCM port, scm_print_state *pstate)
 439 {
 440   scm_prinport (exp, port, "pipe");
 441   return 1;
 442 }
 443
 444
 445
 446 /* On SunOS, there's no declaration for pclose in the headers, so
 447    putting it directly in the initializer for scm_pipob doesn't really
 448    fly.  We could add an extern declaration for it, but then it'll
 449    mismatch on some systems that do have a declaration.  So we just
 450    wrap it up this way.  */
 451 static int
 452 local_pclose (fp)
 453      FILE * fp;
 454 {
 455   return pclose (fp);
 456 }
 457
 458 \f
 459 scm_ptobfuns scm_fptob =
 460 {
 461   scm_mark0,
 462   (int (*) SCM_P ((SCM))) local_fclose,
 463   prinfport,
 464   0,
 465   (int (*) SCM_P ((int, SCM))) local_fputc,
 466   (int (*) SCM_P ((char *, SCM))) local_fputs,
 467   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 468   (int (*) SCM_P ((SCM))) local_fflush,
 469   (int (*) SCM_P ((SCM))) scm_fgetc,
 470   (char * (*) SCM_P ((SCM, int *))) scm_fgets,
 471   (int (*) SCM_P ((SCM))) local_fclose
 472 };
 473
 474 /* {Pipe ports} */
 475 scm_ptobfuns scm_pipob =
 476 {
 477   scm_mark0,
 478   (int (*) SCM_P ((SCM))) local_pclose,
 479   print_pipe_port,
 480   0,
 481   (int (*) SCM_P ((int, SCM))) local_fputc,
 482   (int (*) SCM_P ((char *, SCM))) local_fputs,
 483   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 484   (int (*) SCM_P ((SCM))) local_fflush,
 485   (int (*) SCM_P ((SCM))) scm_fgetc,
 486   (char * (*) SCM_P ((SCM, int *))) scm_fgets,
 487   (int (*) SCM_P ((SCM))) local_pclose
 488 };
 489
 490 void
 491 scm_init_fports ()
 492 {
 493 #include "fports.x"
 494   scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
 495   scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
 496   scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
 497 }