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   /* If there are any pushed-back characters, read the line character
 152      by character.  */
 153   if (SCM_CRDYP (port))
 154     {
 155       int buf_size = 60;
 156       /* Invariant: buf always has buf_size + 1 characters allocated;
 157          the `+ 1' is for the final '\0'.  */
 158       unsigned char *buf = malloc (buf_size + 1);
 159       int buf_len = 0;
 160       int c;
 161
 162       while ((c = scm_getc (port)) != EOF)
 163         {
 164           if (buf_len >= buf_size)
 165             {
 166               buf = realloc (buf, buf_size * 2 + 1);
 167               buf_size *= 2;
 168             }
 169
 170           buf[buf_len++] = c;
 171
 172           if (c == '\n')
 173             break;
 174         }
 175
 176       /* Since SCM_CRDYP returned true, we ought to have gotten at
 177          least one character.  */
 178       if (buf_len == 0)
 179         abort ();
 180
 181       buf[buf_len] = '\0';
 182
 183       *len_p = buf_len;
 184       return buf;
 185     }
 186
 187   /* The common case: no unread characters, and the buffer contains
 188      a complete line.  This needs to be fast.  */
 189   if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
 190            != 0)
 191     {
 192       int buf_len = (end + 1) - pt->read_pos;
 193       /* Allocate a buffer of the perfect size.  */
 194       unsigned char *buf = malloc (buf_len + 1);
 195
 196       memcpy (buf, pt->read_pos, buf_len);
 197       pt->read_pos += buf_len;
 198
 199       buf[buf_len] = '\0';
 200
 201       *len_p = buf_len;
 202       return buf;
 203     }
 204
 205   /* There are no unread characters, and the buffer contains no newlines.  */
 206   {
 207     /* When live, len is always the number of characters in the
 208        current buffer that are part of the current line.  */
 209     int len = (pt->read_end - pt->read_pos);
 210     int buf_size = (len < 50) ? 60 : len * 2;
 211     /* Invariant: buf always has buf_size + 1 characters allocated;
 212        the `+ 1' is for the final '\0'.  */
 213     unsigned char *buf = malloc (buf_size + 1);
 214     int buf_len = 0;
 215     int c;
 216
 217     for (;;)
 218       {
 219         if (buf_len + len > buf_size)
 220           {
 221             int new_size = (buf_len + len) * 2;
 222             buf = realloc (buf, new_size + 1);
 223             buf_size = new_size;
 224           }
 225
 226         /* Copy what we've got out of the port, into our buffer.  */
 227         memcpy (buf + buf_len, pt->read_pos, len);
 228         buf_len += len;
 229         pt->read_pos += len;
 230
 231         /* If we had seen a newline, we're done now.  */
 232         if (end)
 233           break;
 234
 235         /* Get more characters.  I think having fill_buffer return a
 236            character is not terribly graceful...  */
 237         c = (scm_ptobs[SCM_PTOBNUM (port)].fill_buffer) (port);
 238         if (c == EOF)
 239           {
 240             /* If we're missing a final newline in the file, return
 241                what we did get, sans newline.  */
 242             if (buf_len > 0)
 243               break;
 244
 245             free (buf);
 246             return 0;
 247           }
 248
 249         /* ... because it makes us duplicate code here...  */
 250         if (buf_len + 1 > buf_size)
 251           {
 252             int new_size = buf_size * 2;
 253             buf = realloc (buf, new_size + 1);
 254             buf_size = new_size;
 255           }
 256
 257         /* ... and this is really a duplication of the memcpy and
 258            memchr calls, on a single-byte buffer.  */
 259         buf[buf_len++] = c;
 260         if (c == '\n')
 261           break;
 262
 263         /* Search the buffer for newlines.  */
 264         if ((end = memchr (pt->read_pos, '\n',
 265                            (len = (pt->read_end - pt->read_pos))))
 266             != 0)
 267           len = (end - pt->read_pos) + 1;
 268       }
 269
 270     /* I wonder how expensive this realloc is.  */
 271     buf = realloc (buf, buf_len + 1);
 272     buf[buf_len] = '\0';
 273     *len_p = buf_len;
 274     return buf;
 275   }
 276 }
 277
 278
 279 /*
 280  * %read-line
 281  * truncates any terminating newline from its input, and returns
 282  * a cons of the string read and its terminating character.  Doing
 283  * so makes it easy to implement the hairy `read-line' options
 284  * efficiently in Scheme.
 285  */
 286
 287 SCM_PROC (s_read_line, "%read-line", 0, 1, 0, scm_read_line);
 288
 289 SCM
 290 scm_read_line (port)
 291      SCM port;
 292 {
 293   scm_port *pt;
 294   char *s;
 295   int slen;
 296   SCM line, term;
 297
 298   if (SCM_UNBNDP (port))
 299     port = scm_cur_inp;
 300   else
 301     {
 302       SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
 303                   port, SCM_ARG1, s_read_line);
 304     }
 305
 306   pt = SCM_PTAB_ENTRY (port);
 307   if (pt->rw_active == SCM_PORT_WRITE)
 308     scm_ptobs[SCM_PTOBNUM (port)].fflush (port);
 309
 310   s = scm_do_read_line (port, &slen);
 311
 312   if (s == NULL)
 313     term = line = SCM_EOF_VAL;
 314   else
 315     {
 316       if (s[slen-1] == '\n')
 317         {
 318           term = SCM_MAKICHR ('\n');
 319           s[slen-1] = '\0';
 320           line = scm_take_str (s, slen-1);
 321           SCM_INCLINE (port);
 322         }
 323       else
 324         {
 325           /* Fix: we should check for eof on the port before assuming this. */
 326           term = SCM_EOF_VAL;
 327           line = scm_take_str (s, slen);
 328           SCM_COL (port) += slen;
 329         }
 330     }
 331
 332   if (pt->rw_random)
 333     pt->rw_active = SCM_PORT_READ;
 334
 335   return scm_cons (line, term);
 336 }
 337
 338 SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
 339
 340 SCM
 341 scm_write_line (obj, port)
 342      SCM obj;
 343      SCM port;
 344 {
 345   scm_display (obj, port);
 346   return scm_newline (port);
 347 }
 348
 349 SCM_PROC (s_ftell, "ftell", 1, 0, 0, scm_ftell);
 350
 351 SCM
 352 scm_ftell (object)
 353      SCM object;
 354 {
 355   return scm_lseek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
 356 }
 357
 358 SCM_PROC (s_fseek, "fseek", 3, 0, 0, scm_fseek);
 359
 360 SCM
 361 scm_fseek (object, offset, whence)
 362      SCM object;
 363      SCM offset;
 364      SCM whence;
 365 {
 366   scm_lseek (object, offset, whence);
 367
 368   return SCM_UNSPECIFIED;
 369 }
 370
 371 SCM_PROC (s_redirect_port, "redirect-port", 2, 0, 0, scm_redirect_port);
 372
 373 SCM
 374 scm_redirect_port (old, new)
 375      SCM old;
 376      SCM new;
 377 {
 378   int ans, oldfd, newfd;
 379   struct scm_fport *fp;
 380
 381   old = SCM_COERCE_OUTPORT (old);
 382   new = SCM_COERCE_OUTPORT (new);
 383
 384   SCM_ASSERT (SCM_NIMP (old) && SCM_OPFPORTP (old), old, SCM_ARG1, s_redirect_port);
 385   SCM_ASSERT (SCM_NIMP (new) && SCM_OPFPORTP (new), new, SCM_ARG2, s_redirect_port);
 386   oldfd = SCM_FPORT_FDES (old);
 387   fp = SCM_FSTREAM (new);
 388   newfd = fp->fdes;
 389   if (oldfd != newfd)
 390     {
 391       scm_port *pt = SCM_PTAB_ENTRY (new);
 392       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 393       scm_ptobfuns *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 394
 395       /* must flush to old fdes.  */
 396       if (pt->rw_active == SCM_PORT_WRITE)
 397         ptob->fflush (new);
 398       else if (pt->rw_active == SCM_PORT_READ)
 399         ptob->read_flush (new);
 400       ans = dup2 (oldfd, newfd);
 401       if (ans == -1)
 402         scm_syserror (s_redirect_port);
 403       pt->rw_random = old_pt->rw_random;
 404       /* continue using existing buffers, even if inappropriate.  */
 405     }
 406   return SCM_UNSPECIFIED;
 407 }
 408
 409 SCM_PROC (s_dup_to_fdes, "dup->fdes", 1, 1, 0, scm_dup_to_fdes);
 410 SCM
 411 scm_dup_to_fdes (SCM fd_or_port, SCM fd)
 412 {
 413   int oldfd, newfd, rv;
 414
 415   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 416
 417   if (SCM_INUMP (fd_or_port))
 418     oldfd = SCM_INUM (fd_or_port);
 419   else
 420     {
 421       SCM_ASSERT (SCM_NIMP (fd_or_port) && SCM_OPFPORTP (fd_or_port),
 422                   fd_or_port, SCM_ARG1, s_dup_to_fdes);
 423       oldfd = SCM_FPORT_FDES (fd_or_port);
 424     }
 425
 426   if (SCM_UNBNDP (fd))
 427     {
 428       newfd = dup (oldfd);
 429       if (newfd == -1)
 430         scm_syserror (s_dup_to_fdes);
 431       fd = SCM_MAKINUM (newfd);
 432     }
 433   else
 434     {
 435       SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_dup_to_fdes);
 436       newfd = SCM_INUM (fd);
 437       if (oldfd != newfd)
 438         {
 439           scm_evict_ports (newfd);      /* see scsh manual.  */
 440           rv = dup2 (oldfd, newfd);
 441           if (rv == -1)
 442             scm_syserror (s_dup_to_fdes);
 443         }
 444     }
 445   return fd;
 446 }
 447
 448 SCM_PROC (s_fileno, "fileno", 1, 0, 0, scm_fileno);
 449
 450 SCM
 451 scm_fileno (port)
 452      SCM port;
 453 {
 454   port = SCM_COERCE_OUTPORT (port);
 455   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1,
 456               s_fileno);
 457   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 458 }
 459
 460 SCM_PROC (s_isatty, "isatty?", 1, 0, 0, scm_isatty_p);
 461
 462 SCM
 463 scm_isatty_p (port)
 464      SCM port;
 465 {
 466   int rv;
 467
 468   port = SCM_COERCE_OUTPORT (port);
 469
 470   if (!(SCM_NIMP (port) && SCM_OPFPORTP (port)))
 471     return SCM_BOOL_F;
 472
 473   rv = isatty (SCM_FPORT_FDES (port));
 474   return  rv ? SCM_BOOL_T : SCM_BOOL_F;
 475 }
 476
 477
 478
 479 SCM_PROC (s_fdopen, "fdopen", 2, 0, 0, scm_fdopen);
 480
 481 SCM
 482 scm_fdopen (fdes, modes)
 483      SCM fdes;
 484      SCM modes;
 485 {
 486   SCM port;
 487
 488   SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_fdopen);
 489   SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2,
 490               s_fdopen);
 491   SCM_COERCE_SUBSTR (modes);
 492   port = scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F);
 493   return port;
 494 }
 495
 496
 497
 498 /* Move a port's underlying file descriptor to a given value.
 499  * Returns  #f if fdes is already the given value.
 500  *          #t if fdes moved.
 501  * MOVE->FDES is implemented in Scheme and calls this primitive.
 502  */
 503 SCM_PROC (s_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_primitive_move_to_fdes);
 504
 505 SCM
 506 scm_primitive_move_to_fdes (port, fd)
 507      SCM port;
 508      SCM fd;
 509 {
 510   struct scm_fport *stream;
 511   int old_fd;
 512   int new_fd;
 513   int rv;
 514
 515   port = SCM_COERCE_OUTPORT (port);
 516
 517   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_primitive_move_to_fdes);
 518   SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_primitive_move_to_fdes);
 519   stream = SCM_FSTREAM (port);
 520   old_fd = stream->fdes;
 521   new_fd = SCM_INUM (fd);
 522   if  (old_fd == new_fd)
 523     {
 524       return SCM_BOOL_F;
 525     }
 526   scm_evict_ports (new_fd);
 527   rv = dup2 (old_fd, new_fd);
 528   if (rv == -1)
 529     scm_syserror (s_primitive_move_to_fdes);
 530   stream->fdes = new_fd;
 531   SCM_SYSCALL (close (old_fd));
 532   return SCM_BOOL_T;
 533 }
 534
 535 /* Return a list of ports using a given file descriptor.  */
 536 SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports);
 537
 538 SCM
 539 scm_fdes_to_ports (fd)
 540      SCM fd;
 541 {
 542   SCM result = SCM_EOL;
 543   int int_fd;
 544   int i;
 545
 546   SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports);
 547   int_fd = SCM_INUM (fd);
 548
 549   for (i = 0; i < scm_port_table_size; i++)
 550     {
 551       if (SCM_OPFPORTP (scm_port_table[i]->port)
 552           && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 553         result = scm_cons (scm_port_table[i]->port, result);
 554     }
 555   return result;
 556 }
 557
 558
 559 void
 560 scm_init_ioext ()
 561 {
 562 #include "ioext.x"
 563 }
 564