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   SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG1, s_setvbuf);
  87   SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_setvbuf);
  88   if (SCM_UNBNDP (size))
  89     csize = 0;
  90   else
  91     {
  92       SCM_ASSERT (SCM_INUMP (size), size, SCM_ARG3, s_setvbuf);
  93       csize = SCM_INUM (size);
  94     }
  95   cmode = SCM_INUM (mode);
  96   if (csize == 0 && cmode == _IOFBF)
  97     cmode = _IONBF;
  98   SCM_DEFER_INTS;
  99   SCM_SYSCALL (rv = setvbuf ((FILE *)SCM_STREAM (port), 0, cmode, csize));
 100   if (rv < 0)
 101     scm_syserror (s_setvbuf);
 102   if (cmode == _IONBF)
 103     SCM_SETCAR (port, SCM_CAR (port) | SCM_BUF0);
 104   else
 105     SCM_SETCAR (port, (SCM_CAR (port) & ~SCM_BUF0));
 106   SCM_ALLOW_INTS;
 107   return SCM_UNSPECIFIED;
 108 }
 109
 110 #ifdef FD_SETTER
 111 #define SET_FILE_FD_FIELD(F,D) ((F)->FD_SETTER = (D))
 112 #endif
 113
 114 void
 115 scm_setfileno (fs, fd)
 116      FILE *fs;
 117      int fd;
 118 {
 119 #ifdef SET_FILE_FD_FIELD
 120   SET_FILE_FD_FIELD(fs, fd);
 121 #else
 122   scm_misc_error ("scm_setfileno", "Not fully implemented on this platform",
 123                   SCM_EOL);
 124 #endif
 125 }
 126
 127 /* Move ports with the specified file descriptor to new descriptors,
 128  * reseting the revealed count to 0.
 129  * Should be called with SCM_DEFER_INTS active.
 130  */
 131
 132 void
 133 scm_evict_ports (fd)
 134      int fd;
 135 {
 136   int i;
 137
 138   for (i = 0; i < scm_port_table_size; i++)
 139     {
 140       if (SCM_FPORTP (scm_port_table[i]->port)
 141           && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd)
 142         {
 143           scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd));
 144           scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0));
 145         }
 146     }
 147 }
 148
 149 /* scm_open_file
 150  * Return a new port open on a given file.
 151  *
 152  * The mode string must match the pattern: [rwa+]** which
 153  * is interpreted in the usual unix way.
 154  *
 155  * Return the new port.
 156  */
 157 SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
 158
 159 SCM
 160 scm_open_file (filename, modes)
 161      SCM filename;
 162      SCM modes;
 163 {
 164   SCM port;
 165   FILE *f;
 166   char *file;
 167   char *mode;
 168
 169   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
 170   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
 171   if (SCM_SUBSTRP (filename))
 172     filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
 173   if (SCM_SUBSTRP (modes))
 174     modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
 175
 176   file = SCM_ROCHARS (filename);
 177   mode = SCM_ROCHARS (modes);
 178
 179   SCM_NEWCELL (port);
 180   SCM_DEFER_INTS;
 181   SCM_SYSCALL (f = fopen (file, mode));
 182   if (!f)
 183     {
 184       int en = errno;
 185
 186       scm_syserror_msg (s_open_file, "%s: %S",
 187                         scm_listify (scm_makfrom0str (strerror (errno)),
 188                                      filename,
 189                                      SCM_UNDEFINED),
 190                         en);
 191     }
 192   else
 193     {
 194       struct scm_port_table * pt;
 195
 196       pt = scm_add_to_port_table (port);
 197       SCM_SETPTAB_ENTRY (port, pt);
 198       SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode));
 199       SCM_SETSTREAM (port, (SCM) f);
 200       if (SCM_BUF0 & SCM_CAR (port))
 201         scm_setbuf0 (port);
 202       SCM_PTAB_ENTRY (port)->file_name = filename;
 203     }
 204   SCM_ALLOW_INTS;
 205   return port;
 206 }
 207
 208
 209 /* Build a Scheme port from an open stdio port, FILE.
 210    MODE indicates whether FILE is open for reading or writing; it uses
 211       the same notation as open-file's second argument.
 212    If NAME is non-zero, use it as the port's filename.
 213
 214    scm_stdio_to_port sets the revealed count for FILE's file
 215    descriptor to 1, so that FILE won't be closed when the port object
 216    is GC'd.  */
 217 SCM
 218 scm_stdio_to_port (file, mode, name)
 219      FILE *file;
 220      char *mode;
 221      char *name;
 222 {
 223   long mode_bits = scm_mode_bits (mode);
 224   SCM port;
 225   struct scm_port_table * pt;
 226
 227   SCM_NEWCELL (port);
 228   SCM_DEFER_INTS;
 229   {
 230     pt = scm_add_to_port_table (port);
 231     SCM_SETPTAB_ENTRY (port, pt);
 232     SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
 233     SCM_SETSTREAM (port, (SCM) file);
 234     if (SCM_BUF0 & SCM_CAR (port))
 235       scm_setbuf0 (port);
 236     SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
 237   }
 238   SCM_ALLOW_INTS;
 239   scm_set_port_revealed_x (port, SCM_MAKINUM (1));
 240   return port;
 241 }
 242
 243
 244
 245 static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 246
 247 static int
 248 prinfport (exp, port, pstate)
 249      SCM exp;
 250      SCM port;
 251      scm_print_state *pstate;
 252 {
 253   SCM name;
 254   char * c;
 255   if (SCM_CLOSEDP (exp))
 256     {
 257       c = "file";
 258     }
 259   else
 260     {
 261       name = SCM_PTAB_ENTRY (exp)->file_name;
 262       if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 263         c = SCM_ROCHARS (name);
 264       else
 265         c = "file";
 266     }
 267
 268   scm_prinport (exp, port, c);
 269   return !0;
 270 }
 271
 272
 273
 274 static int scm_fgetc SCM_P ((FILE * s));
 275
 276 static int
 277 scm_fgetc (s)
 278      FILE * s;
 279 {
 280   if (feof (s))
 281     return EOF;
 282   else
 283     return fgetc (s);
 284 }
 285
 286 /*
 287  * The fgets method must take a port as its argument, rather than
 288  * the underlying file handle.  The reason is that we also provide
 289  * a generic fgets method for ports which can't use fgets(3) (e.g.
 290  * string ports).  This generic method calls the port's own
 291  * fgetc method.  In order for it to know how to get that method,
 292  * we must pass the original Scheme port object.
 293  */
 294
 295 static char * scm_fgets SCM_P ((SCM port));
 296
 297 static char *
 298 scm_fgets (port)
 299      SCM port;
 300 {
 301   FILE *f;
 302
 303   char *buf   = NULL;
 304   char *p;              /* pointer to current buffer position */
 305   int   i     = 0;      /* index into current buffer position */
 306   int   limit = 80;     /* current size of buffer */
 307
 308   f = (FILE *) SCM_STREAM (port);
 309   if (feof (f))
 310     return NULL;
 311
 312   buf = (char *) scm_must_malloc (limit * sizeof(char), "fgets");
 313
 314   while (1) {
 315     p = buf + i;
 316     if (fgets (p, limit - i, f) == NULL) {
 317       if (i)
 318         return buf;
 319       scm_must_free (buf);
 320       return NULL;
 321     }
 322
 323     if (strlen(p) < limit - i - 1)
 324       return buf;
 325
 326     buf = (char *) scm_must_realloc (buf,
 327                                      sizeof(char) * limit,
 328                                      sizeof(char) * limit * 2,
 329                                      "fgets");
 330
 331     i = limit - 1;
 332     limit *= 2;
 333   }
 334 }
 335
 336 #ifdef vms
 337
 338 static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
 339
 340 static scm_sizet
 341 pwrite (ptr, size, nitems, port)
 342      char *ptr;
 343      scm_sizet size, nitems;
 344      FILE *port;
 345 {
 346   scm_sizet len = size * nitems;
 347   scm_sizet i = 0;
 348   for (; i < len; i++)
 349     putc (ptr[i], port);
 350   return len;
 351 }
 352
 353 #define ffwrite pwrite
 354 #else
 355 #define ffwrite fwrite
 356 #endif
 357
 358 \f
 359 /* This otherwise pointless code helps some poor
 360  * crippled C compilers cope with life.
 361  */
 362
 363 static int local_fclose SCM_P ((FILE *fp));
 364
 365 static int
 366 local_fclose (fp)
 367      FILE * fp;
 368 {
 369   return fclose (fp);
 370 }
 371
 372 static int local_fflush SCM_P ((FILE *fp));
 373
 374 static int
 375 local_fflush (fp)
 376      FILE * fp;
 377 {
 378   return fflush (fp);
 379 }
 380
 381 static int local_fputc SCM_P ((int c, FILE *fp));
 382
 383 static int
 384 local_fputc (c, fp)
 385      int c;
 386      FILE * fp;
 387 {
 388   return fputc (c, fp);
 389 }
 390
 391 static int local_fputs SCM_P ((char *s, FILE *fp));
 392
 393 static int
 394 local_fputs (s, fp)
 395      char * s;
 396      FILE * fp;
 397 {
 398   return fputs (s, fp);
 399 }
 400
 401 static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp));
 402
 403 static scm_sizet
 404 local_ffwrite (ptr, size, nitems, fp)
 405      void * ptr;
 406      int size;
 407      int nitems;
 408      FILE * fp;
 409 {
 410   return ffwrite (ptr, size, nitems, fp);
 411 }
 412
 413 static int
 414 print_pipe_port (SCM exp, SCM port, scm_print_state *pstate)
 415 {
 416   scm_prinport (exp, port, "pipe");
 417   return 1;
 418 }
 419
 420
 421
 422 /* On SunOS, there's no declaration for pclose in the headers, so
 423    putting it directly in the initializer for scm_pipob doesn't really
 424    fly.  We could add an extern declaration for it, but then it'll
 425    mismatch on some systems that do have a declaration.  So we just
 426    wrap it up this way.  */
 427 static int
 428 local_pclose (fp)
 429      FILE * fp;
 430 {
 431   return pclose (fp);
 432 }
 433
 434 \f
 435 scm_ptobfuns scm_fptob =
 436 {
 437   scm_mark0,
 438   (int (*) SCM_P ((SCM))) local_fclose,
 439   prinfport,
 440   0,
 441   (int (*) SCM_P ((int, SCM))) local_fputc,
 442   (int (*) SCM_P ((char *, SCM))) local_fputs,
 443   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 444   (int (*) SCM_P ((SCM))) local_fflush,
 445   (int (*) SCM_P ((SCM))) scm_fgetc,
 446   (char * (*) SCM_P ((SCM))) scm_fgets,
 447   (int (*) SCM_P ((SCM))) local_fclose
 448 };
 449
 450 /* {Pipe ports} */
 451 scm_ptobfuns scm_pipob =
 452 {
 453   scm_mark0,
 454   (int (*) SCM_P ((SCM))) local_pclose,
 455   print_pipe_port,
 456   0,
 457   (int (*) SCM_P ((int, SCM))) local_fputc,
 458   (int (*) SCM_P ((char *, SCM))) local_fputs,
 459   (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
 460   (int (*) SCM_P ((SCM))) local_fflush,
 461   (int (*) SCM_P ((SCM))) scm_fgetc,
 462   (char * (*) SCM_P ((SCM))) scm_fgets,
 463   (int (*) SCM_P ((SCM))) local_pclose
 464 };
 465
 466 void
 467 scm_init_fports ()
 468 {
 469 #include "fports.x"
 470   scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
 471   scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
 472   scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
 473 }