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
 277 local_fgetc (SCM port)
 278 {
 279   FILE *s = (FILE *) SCM_STREAM (port);
 280   if (feof (s))
 281     return EOF;
 282   else
 283     return fgetc (s);
 284 }
 285
 286
 287 static char *
 288 local_fgets (SCM port, int *len)
 289 {
 290   FILE *f;
 291
 292   char *buf   = NULL;
 293   char *p;              /* pointer to current buffer position */
 294   int   limit = 80;     /* current size of buffer */
 295
 296   f = (FILE *) SCM_STREAM (port);
 297   if (feof (f))
 298     return NULL;
 299
 300   buf = (char *) malloc (limit * sizeof(char));
 301   *len = 0;
 302
 303   /* If a char has been pushed onto the port with scm_ungetc,
 304      read that first. */
 305   if (SCM_CRDYP (port))
 306     {
 307       buf[*len] = SCM_CGETUN (port);
 308       SCM_CLRDY (port);
 309       if (buf[(*len)++] == '\n')
 310         {
 311           buf[*len] = '\0';
 312           return buf;
 313         }
 314     }
 315
 316   while (1)
 317     {
 318       int chunk_size = limit - *len;
 319       long int numread, pos;
 320
 321       p = buf + *len;
 322
 323       /* We must use ftell to figure out how many characters were read.
 324          If there are null characters near the end of file, and no
 325          terminating newline, there is no other way to tell the difference
 326          between an embedded null and the string-terminating null. */
 327
 328       pos = ftell (f);
 329       if (fgets (p, chunk_size, f) == NULL) {
 330         if (*len)
 331           return buf;
 332         free (buf);
 333         return NULL;
 334       }
 335       numread = ftell (f) - pos;
 336       *len += numread;
 337
 338       if (numread < chunk_size - 1 || buf[limit-2] == '\n')
 339         return buf;
 340
 341       buf = (char *) realloc (buf, sizeof(char) * limit * 2);
 342       limit *= 2;
 343     }
 344 }
 345
 346 #ifdef vms
 347
 348 static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
 349
 350 static scm_sizet
 351 pwrite (ptr, size, nitems, port)
 352      char *ptr;
 353      scm_sizet size, nitems;
 354      FILE *port;
 355 {
 356   scm_sizet len = size * nitems;
 357   scm_sizet i = 0;
 358   for (; i < len; i++)
 359     putc (ptr[i], port);
 360   return len;
 361 }
 362
 363 #define ffwrite pwrite
 364 #else
 365 #define ffwrite fwrite
 366 #endif
 367
 368 \f
 369 /* This otherwise pointless code helps some poor
 370  * crippled C compilers cope with life.
 371  */
 372
 373 static int
 374 local_fclose (SCM port)
 375 {
 376   FILE *fp = (FILE *) SCM_STREAM (port);
 377
 378   return fclose (fp);
 379 }
 380
 381 static int
 382 local_fflush (SCM port)
 383 {
 384   FILE *fp = (FILE *) SCM_STREAM (port);
 385   return fflush (fp);
 386 }
 387
 388 static int
 389 local_fputc (int c, SCM port)
 390 {
 391   FILE *fp = (FILE *) SCM_STREAM (port);
 392
 393   return fputc (c, fp);
 394 }
 395
 396 static int
 397 local_fputs (char *s, SCM port)
 398 {
 399   FILE *fp = (FILE *) SCM_STREAM (port);
 400   return fputs (s, fp);
 401 }
 402
 403 static scm_sizet
 404 local_ffwrite (char *ptr,
 405                scm_sizet size,
 406                scm_sizet nitems,
 407                SCM port)
 408 {
 409   FILE *fp = (FILE *) SCM_STREAM (port);
 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 static int
 421 local_pclose (SCM port)
 422 {
 423   FILE *fp = (FILE *) SCM_STREAM (port);
 424
 425   return pclose (fp);
 426 }
 427
 428 \f
 429 scm_ptobfuns scm_fptob =
 430 {
 431   0,
 432   local_fclose,
 433   prinfport,
 434   0,
 435   local_fputc,
 436   local_fputs,
 437   local_ffwrite,
 438   local_fflush,
 439   local_fgetc,
 440   local_fgets,
 441   local_fclose
 442 };
 443
 444 /* {Pipe ports} */
 445 scm_ptobfuns scm_pipob =
 446 {
 447   0,
 448   local_pclose,
 449   print_pipe_port,
 450   0,
 451   local_fputc,
 452   local_fputs,
 453   local_ffwrite,
 454   local_fflush,
 455   local_fgetc,
 456   scm_generic_fgets,
 457   local_pclose
 458 };
 459
 460 void
 461 scm_init_fports ()
 462 {
 463 #include "fports.x"
 464   scm_sysintern ("_IOFBF", SCM_MAKINUM (_IOFBF));
 465   scm_sysintern ("_IOLBF", SCM_MAKINUM (_IOLBF));
 466   scm_sysintern ("_IONBF", SCM_MAKINUM (_IONBF));
 467 }