libguile/ioext.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999 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
  44 #include <stdio.h>
  45 #include "_scm.h"
  46 #include "ports.h"
  47 #include "read.h"
  48 #include "fports.h"
  49 #include "unif.h"
  50 #include "chars.h"
  51
  52 #include "ioext.h"
  53
  54 #include <fcntl.h>
  55
  56 #ifdef HAVE_STRING_H
  57 #include <string.h>
  58 #endif
  59 #ifdef HAVE_UNISTD_H
  60 #include <unistd.h>
  61 #endif
  62 \f
  63
  64 SCM_PROC (s_read_delimited_x, "%read-delimited!", 3, 3, 0, scm_read_delimited_x);
  65
  66 SCM
  67 scm_read_delimited_x (delims, buf, gobble, port, start, end)
  68      SCM delims;
  69      SCM buf;
  70      SCM gobble;
  71      SCM port;
  72      SCM start;
  73      SCM end;
  74 {
  75   long j;
  76   char *cbuf;
  77   long cstart;
  78   long cend;
  79   int c;
  80   char *cdelims;
  81   int num_delims;
  82
  83   SCM_ASSERT (SCM_NIMP (delims) && SCM_ROSTRINGP (delims),
  84               delims, SCM_ARG1, s_read_delimited_x);
  85   cdelims = SCM_ROCHARS (delims);
  86   num_delims = SCM_ROLENGTH (delims);
  87   SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf),
  88               buf, SCM_ARG2, s_read_delimited_x);
  89   cbuf = SCM_CHARS (buf);
  90   cend = SCM_LENGTH (buf);
  91   if (SCM_UNBNDP (port))
  92     port = scm_cur_inp;
  93   else
  94     {
  95       SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
  96                   port, SCM_ARG1, s_read_delimited_x);
  97     }
  98
  99   if (SCM_UNBNDP (start))
 100     cstart = 0;
 101   else
 102     {
 103       cstart = scm_num2long (start,
 104                              (char *) SCM_ARG5, s_read_delimited_x);
 105       if (cstart < 0 || cstart >= cend)
 106         scm_out_of_range (s_read_delimited_x, start);
 107
 108       if (!SCM_UNBNDP (end))
 109         {
 110           long tend = scm_num2long (end, (char *) SCM_ARG6,
 111                                     s_read_delimited_x);
 112           if (tend <= cstart || tend > cend)
 113             scm_out_of_range (s_read_delimited_x, end);
 114           cend = tend;
 115         }
 116     }
 117
 118   for (j = cstart; j < cend; j++)
 119     {
 120       int k;
 121
 122       c = scm_getc (port);
 123       for (k = 0; k < num_delims; k++)
 124         {
 125           if (cdelims[k] == c)
 126             {
 127               if (SCM_FALSEP (gobble))
 128                 scm_ungetc (c, port);
 129
 130               return scm_cons (SCM_MAKICHR (c),
 131                                scm_long2num (j - cstart));
 132             }
 133         }
 134       if (c == EOF)
 135         return scm_cons (SCM_EOF_VAL,
 136                          scm_long2num (j - cstart));
 137
 138       cbuf[j] = c;
 139     }
 140   return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
 141 }
 142
 143 static unsigned char *
 144 scm_do_read_line (SCM port, int *len_p)
 145 {
 146   scm_port *pt = SCM_PTAB_ENTRY (port);
 147   unsigned char *end;
 148
 149   /* I thought reading lines was simple.  Mercy me.  */
 150
 151   /* The common case: the buffer contains a complete line.
 152      This needs to be fast.  */
 153   if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
 154            != 0)
 155     {
 156       int buf_len = (end + 1) - pt->read_pos;
 157       /* Allocate a buffer of the perfect size.  */
 158       unsigned char *buf = malloc (buf_len + 1);
 159
 160       memcpy (buf, pt->read_pos, buf_len);
 161       pt->read_pos += buf_len;
 162
 163       buf[buf_len] = '\0';
 164
 165       *len_p = buf_len;
 166       return buf;
 167     }
 168
 169   /* The buffer contains no newlines.  */
 170   {
 171     /* When live, len is always the number of characters in the
 172        current buffer that are part of the current line.  */
 173     int len = (pt->read_end - pt->read_pos);
 174     int buf_size = (len < 50) ? 60 : len * 2;
 175     /* Invariant: buf always has buf_size + 1 characters allocated;
 176        the `+ 1' is for the final '\0'.  */
 177     unsigned char *buf = malloc (buf_size + 1);
 178     int buf_len = 0;
 179     int c;
 180
 181     for (;;)
 182       {
 183         if (buf_len + len > buf_size)
 184           {
 185             int new_size = (buf_len + len) * 2;
 186             buf = realloc (buf, new_size + 1);
 187             buf_size = new_size;
 188           }
 189
 190         /* Copy what we've got out of the port, into our buffer.  */
 191         memcpy (buf + buf_len, pt->read_pos, len);
 192         buf_len += len;
 193         pt->read_pos += len;
 194
 195         /* If we had seen a newline, we're done now.  */
 196         if (end)
 197           break;
 198
 199         /* Get more characters.  I think having fill_buffer return a
 200            character is not terribly graceful...  */
 201         c = scm_fill_buffer (port);
 202         if (c == EOF)
 203           {
 204             /* If we're missing a final newline in the file, return
 205                what we did get, sans newline.  */
 206             if (buf_len > 0)
 207               break;
 208
 209             free (buf);
 210             return 0;
 211           }
 212
 213         /* ... because it makes us duplicate code here...  */
 214         if (buf_len + 1 > buf_size)
 215           {
 216             int new_size = buf_size * 2;
 217             buf = realloc (buf, new_size + 1);
 218             buf_size = new_size;
 219           }
 220
 221         /* ... and this is really a duplication of the memcpy and
 222            memchr calls, on a single-byte buffer.  */
 223         buf[buf_len++] = c;
 224         if (c == '\n')
 225           break;
 226
 227         /* Search the buffer for newlines.  */
 228         if ((end = memchr (pt->read_pos, '\n',
 229                            (len = (pt->read_end - pt->read_pos))))
 230             != 0)
 231           len = (end - pt->read_pos) + 1;
 232       }
 233
 234     /* I wonder how expensive this realloc is.  */
 235     buf = realloc (buf, buf_len + 1);
 236     buf[buf_len] = '\0';
 237     *len_p = buf_len;
 238     return buf;
 239   }
 240 }
 241
 242
 243 /*
 244  * %read-line
 245  * truncates any terminating newline from its input, and returns
 246  * a cons of the string read and its terminating character.  Doing
 247  * so makes it easy to implement the hairy `read-line' options
 248  * efficiently in Scheme.
 249  */
 250
 251 SCM_PROC (s_read_line, "%read-line", 0, 1, 0, scm_read_line);
 252
 253 SCM
 254 scm_read_line (port)
 255      SCM port;
 256 {
 257   scm_port *pt;
 258   char *s;
 259   int slen;
 260   SCM line, term;
 261
 262   if (SCM_UNBNDP (port))
 263     port = scm_cur_inp;
 264   else
 265     {
 266       SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
 267                   port, SCM_ARG1, s_read_line);
 268     }
 269
 270   pt = SCM_PTAB_ENTRY (port);
 271   if (pt->rw_active == SCM_PORT_WRITE)
 272     scm_ptobs[SCM_PTOBNUM (port)].fflush (port);
 273
 274   s = scm_do_read_line (port, &slen);
 275
 276   if (s == NULL)
 277     term = line = SCM_EOF_VAL;
 278   else
 279     {
 280       if (s[slen-1] == '\n')
 281         {
 282           term = SCM_MAKICHR ('\n');
 283           s[slen-1] = '\0';
 284           line = scm_take_str (s, slen-1);
 285           SCM_INCLINE (port);
 286         }
 287       else
 288         {
 289           /* Fix: we should check for eof on the port before assuming this. */
 290           term = SCM_EOF_VAL;
 291           line = scm_take_str (s, slen);
 292           SCM_COL (port) += slen;
 293         }
 294     }
 295
 296   if (pt->rw_random)
 297     pt->rw_active = SCM_PORT_READ;
 298
 299   return scm_cons (line, term);
 300 }
 301
 302 SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
 303
 304 SCM
 305 scm_write_line (obj, port)
 306      SCM obj;
 307      SCM port;
 308 {
 309   scm_display (obj, port);
 310   return scm_newline (port);
 311 }
 312
 313 SCM_PROC (s_ftell, "ftell", 1, 0, 0, scm_ftell);
 314
 315 SCM
 316 scm_ftell (object)
 317      SCM object;
 318 {
 319   return scm_lseek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
 320 }
 321
 322 SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek);
 323
 324 SCM
 325 scm_fseek (object, offset, whence)
 326      SCM object;
 327      SCM offset;
 328      SCM whence;
 329 {
 330   scm_lseek (object, offset, whence);
 331
 332   return SCM_UNSPECIFIED;
 333 }
 334
 335 SCM_PROC (s_redirect_port, "redirect-port", 2, 0, 0, scm_redirect_port);
 336
 337 SCM
 338 scm_redirect_port (old, new)
 339      SCM old;
 340      SCM new;
 341 {
 342   int ans, oldfd, newfd;
 343   struct scm_fport *fp;
 344
 345   old = SCM_COERCE_OUTPORT (old);
 346   new = SCM_COERCE_OUTPORT (new);
 347
 348   SCM_ASSERT (SCM_NIMP (old) && SCM_OPFPORTP (old), old, SCM_ARG1, s_redirect_port);
 349   SCM_ASSERT (SCM_NIMP (new) && SCM_OPFPORTP (new), new, SCM_ARG2, s_redirect_port);
 350   oldfd = SCM_FPORT_FDES (old);
 351   fp = SCM_FSTREAM (new);
 352   newfd = fp->fdes;
 353   if (oldfd != newfd)
 354     {
 355       scm_port *pt = SCM_PTAB_ENTRY (new);
 356       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 357       scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 358
 359       /* must flush to old fdes.  */
 360       if (pt->rw_active == SCM_PORT_WRITE)
 361         ptob->fflush (new);
 362       else if (pt->rw_active == SCM_PORT_READ)
 363         scm_read_flush (new);
 364       ans = dup2 (oldfd, newfd);
 365       if (ans == -1)
 366         scm_syserror (s_redirect_port);
 367       pt->rw_random = old_pt->rw_random;
 368       /* continue using existing buffers, even if inappropriate.  */
 369     }
 370   return SCM_UNSPECIFIED;
 371 }
 372
 373 SCM_PROC (s_dup_to_fdes, "dup->fdes", 1, 1, 0, scm_dup_to_fdes);
 374 SCM
 375 scm_dup_to_fdes (SCM fd_or_port, SCM fd)
 376 {
 377   int oldfd, newfd, rv;
 378
 379   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 380
 381   if (SCM_INUMP (fd_or_port))
 382     oldfd = SCM_INUM (fd_or_port);
 383   else
 384     {
 385       SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPFPORTP (fd_or_port),
 386                   fd_or_port, SCM_ARG1, s_dup_to_fdes);
 387       oldfd = SCM_FPORT_FDES (fd_or_port);
 388     }
 389
 390   if (SCM_UNBNDP (fd))
 391     {
 392       newfd = dup (oldfd);
 393       if (newfd == -1)
 394         scm_syserror (s_dup_to_fdes);
 395       fd = SCM_MAKINUM (newfd);
 396     }
 397   else
 398     {
 399       SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_dup_to_fdes);
 400       newfd = SCM_INUM (fd);
 401       if (oldfd != newfd)
 402         {
 403           scm_evict_ports (newfd);      /* see scsh manual.  */
 404           rv = dup2 (oldfd, newfd);
 405           if (rv == -1)
 406             scm_syserror (s_dup_to_fdes);
 407         }
 408     }
 409   return fd;
 410 }
 411
 412 SCM_PROC (s_fileno, "fileno", 1, 0, 0, scm_fileno);
 413
 414 SCM
 415 scm_fileno (port)
 416      SCM port;
 417 {
 418   port = SCM_COERCE_OUTPORT (port);
 419   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1,
 420               s_fileno);
 421   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 422 }
 423
 424 SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p);
 425
 426 SCM
 427 scm_isatty_p (port)
 428      SCM port;
 429 {
 430   int rv;
 431
 432   port = SCM_COERCE_OUTPORT (port);
 433
 434   if (!(SCM_NIMP (port) && SCM_OPFPORTP (port)))
 435     return SCM_BOOL_F;
 436
 437   rv = isatty (SCM_FPORT_FDES (port));
 438   return  rv ? SCM_BOOL_T : SCM_BOOL_F;
 439 }
 440
 441
 442
 443 SCM_PROC (s_fdopen, "fdopen", 2, 0, 0, scm_fdopen);
 444
 445 SCM
 446 scm_fdopen (fdes, modes)
 447      SCM fdes;
 448      SCM modes;
 449 {
 450   SCM port;
 451
 452   SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen);
 453   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
 454               s_fdopen);
 455   SCM_COERCE_SUBSTR (modes);
 456   port = scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F);
 457   return port;
 458 }
 459
 460
 461
 462 /* Move a port's underlying file descriptor to a given value.
 463  * Returns  #f if fdes is already the given value.
 464  *          #t if fdes moved.
 465  * MOVE->FDES is implemented in Scheme and calls this primitive.
 466  */
 467 SCM_PROC (s_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_primitive_move_to_fdes);
 468
 469 SCM
 470 scm_primitive_move_to_fdes (port, fd)
 471      SCM port;
 472      SCM fd;
 473 {
 474   struct scm_fport *stream;
 475   int old_fd;
 476   int new_fd;
 477   int rv;
 478
 479   port = SCM_COERCE_OUTPORT (port);
 480
 481   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes);
 482   SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes);
 483   stream = SCM_FSTREAM (port);
 484   old_fd = stream->fdes;
 485   new_fd = SCM_INUM (fd);
 486   if  (old_fd == new_fd)
 487     {
 488       return SCM_BOOL_F;
 489     }
 490   scm_evict_ports (new_fd);
 491   rv = dup2 (old_fd, new_fd);
 492   if (rv == -1)
 493     scm_syserror (s_primitive_move_to_fdes);
 494   stream->fdes = new_fd;
 495   SCM_SYSCALL (close (old_fd));
 496   return SCM_BOOL_T;
 497 }
 498
 499 /* Return a list of ports using a given file descriptor.  */
 500 SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports);
 501
 502 SCM
 503 scm_fdes_to_ports (fd)
 504      SCM fd;
 505 {
 506   SCM result = SCM_EOL;
 507   int int_fd;
 508   int i;
 509
 510   SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports);
 511   int_fd = SCM_INUM (fd);
 512
 513   for (i = 0; i < scm_port_table_size; i++)
 514     {
 515       if (SCM_OPFPORTP (scm_port_table[i]->port)
 516           && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 517         result = scm_cons (scm_port_table[i]->port, result);
 518     }
 519   return result;
 520 }
 521
 522
 523 void
 524 scm_init_ioext ()
 525 {
 526 #include "ioext.x"
 527 }
 528