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
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47
  48 #include <stdio.h>
  49 #include "_scm.h"
  50 #include "ports.h"
  51 #include "read.h"
  52 #include "fports.h"
  53 #include "unif.h"
  54 #include "chars.h"
  55 #include "feature.h"
  56 #include "root.h"
  57 #include "strings.h"
  58
  59 #include "validate.h"
  60 #include "ioext.h"
  61
  62 #include <fcntl.h>
  63
  64 #ifdef HAVE_STRING_H
  65 #include <string.h>
  66 #endif
  67 #ifdef HAVE_UNISTD_H
  68 #include <unistd.h>
  69 #endif
  70 \f
  71
  72 SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
  73             (SCM delims, SCM buf, SCM gobble, SCM port, SCM start, SCM end),
  74             "Read characters from @var{port} into @var{buf} until one of the\n"
  75             "characters in the @var{delims} string is encountered.  If @var{gobble?}\n"
  76             "is true, store the delimiter character in @var{buf} as well; otherwise,\n"
  77             "discard it.  If @var{port} is not specified, use the value of\n"
  78             "@code{(current-input-port)}.  If @var{start} or @var{end} are specified,\n"
  79             "store data only into the substring of @var{buf} bounded by @var{start}\n"
  80             "and @var{end} (which default to the beginning and end of the buffer,\n"
  81             "respectively).\n\n"
  82             "Return a pair consisting of the delimiter that terminated the string and\n"
  83             "the number of characters read.  If reading stopped at the end of file,\n"
  84             "the delimiter returned is the @var{eof-object}; if the buffer was filled\n"
  85             "without encountering a delimiter, this value is @var{#f}.")
  86 #define FUNC_NAME s_scm_read_delimited_x
  87 {
  88   long j;
  89   char *cbuf;
  90   long cstart;
  91   long cend, tend;
  92   int c;
  93   char *cdelims;
  94   int num_delims;
  95
  96   SCM_VALIDATE_ROSTRING_COPY (1,delims,cdelims);
  97   num_delims = SCM_ROLENGTH (delims);
  98   SCM_VALIDATE_STRING_COPY (2,buf,cbuf);
  99   cend = SCM_LENGTH (buf);
 100   if (SCM_UNBNDP (port))
 101     port = scm_cur_inp;
 102   else
 103     SCM_VALIDATE_OPINPORT (4,port);
 104
 105   SCM_VALIDATE_INUM_DEF_COPY (5,start,0,cstart);
 106   SCM_ASSERT_RANGE(5, start, cstart >= 0 && cstart < cend);
 107
 108   SCM_VALIDATE_INUM_DEF_COPY (6,end,cend,tend);
 109   SCM_ASSERT_RANGE(6, end, tend > cstart && tend <= cend);
 110
 111   cend = tend;
 112
 113   for (j = cstart; j < cend; j++)
 114     {
 115       int k;
 116
 117       c = scm_getc (port);
 118       for (k = 0; k < num_delims; k++)
 119         {
 120           if (cdelims[k] == c)
 121             {
 122               if (SCM_FALSEP (gobble))
 123                 scm_ungetc (c, port);
 124
 125               return scm_cons (SCM_MAKE_CHAR (c),
 126                                scm_long2num (j - cstart));
 127             }
 128         }
 129       if (c == EOF)
 130         return scm_cons (SCM_EOF_VAL,
 131                          scm_long2num (j - cstart));
 132
 133       cbuf[j] = c;
 134     }
 135   return scm_cons (SCM_BOOL_F, scm_long2num (j - cstart));
 136 }
 137 #undef FUNC_NAME
 138
 139 static unsigned char *
 140 scm_do_read_line (SCM port, int *len_p)
 141 {
 142   scm_port *pt = SCM_PTAB_ENTRY (port);
 143   unsigned char *end;
 144
 145   /* I thought reading lines was simple.  Mercy me.  */
 146
 147   /* The common case: the buffer contains a complete line.
 148      This needs to be fast.  */
 149   if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
 150            != 0)
 151     {
 152       int buf_len = (end + 1) - pt->read_pos;
 153       /* Allocate a buffer of the perfect size.  */
 154       unsigned char *buf = scm_must_malloc (buf_len + 1, "%read-line");
 155
 156       memcpy (buf, pt->read_pos, buf_len);
 157       pt->read_pos += buf_len;
 158
 159       buf[buf_len] = '\0';
 160
 161       *len_p = buf_len;
 162       return buf;
 163     }
 164
 165   /* The buffer contains no newlines.  */
 166   {
 167     /* When live, len is always the number of characters in the
 168        current buffer that are part of the current line.  */
 169     int len = (pt->read_end - pt->read_pos);
 170     int buf_size = (len < 50) ? 60 : len * 2;
 171     /* Invariant: buf always has buf_size + 1 characters allocated;
 172        the `+ 1' is for the final '\0'.  */
 173     unsigned char *buf = scm_must_malloc (buf_size + 1, "%read-line");
 174     int buf_len = 0;
 175
 176     for (;;)
 177       {
 178         if (buf_len + len > buf_size)
 179           {
 180             int new_size = (buf_len + len) * 2;
 181             buf = scm_must_realloc (buf, buf_size + 1, new_size + 1,
 182                                     "%read-line");
 183             buf_size = new_size;
 184           }
 185
 186         /* Copy what we've got out of the port, into our buffer.  */
 187         memcpy (buf + buf_len, pt->read_pos, len);
 188         buf_len += len;
 189         pt->read_pos += len;
 190
 191         /* If we had seen a newline, we're done now.  */
 192         if (end)
 193           break;
 194
 195         /* Get more characters.  */
 196         if (scm_fill_input (port) == EOF)
 197           {
 198             /* If we're missing a final newline in the file, return
 199                what we did get, sans newline.  */
 200             if (buf_len > 0)
 201               break;
 202
 203             free (buf);
 204             return 0;
 205           }
 206
 207         /* Search the buffer for newlines.  */
 208         if ((end = memchr (pt->read_pos, '\n',
 209                            (len = (pt->read_end - pt->read_pos))))
 210             != 0)
 211           len = (end - pt->read_pos) + 1;
 212       }
 213
 214     /* I wonder how expensive this realloc is.  */
 215     buf = scm_must_realloc (buf, buf_size + 1, buf_len + 1, "%read-line");
 216     buf[buf_len] = '\0';
 217     *len_p = buf_len;
 218     return buf;
 219   }
 220 }
 221
 222
 223 /*
 224  * %read-line
 225  * truncates any terminating newline from its input, and returns
 226  * a cons of the string read and its terminating character.  Doing
 227  * so makes it easy to implement the hairy `read-line' options
 228  * efficiently in Scheme.
 229  */
 230
 231 SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
 232             (SCM port),
 233             "Read a newline-terminated line from @var{port}, allocating storage as\n"
 234             "necessary.  The newline terminator (if any) is removed from the string,\n"
 235             "and a pair consisting of the line and its delimiter is returned.  The\n"
 236             "delimiter may be either a newline or the @var{eof-object}; if\n"
 237             "@code{%read-line} is called at the end of file, it returns the pair\n"
 238             "@code{(#<eof> . #<eof>)}.")
 239 #define FUNC_NAME s_scm_read_line
 240 {
 241   scm_port *pt;
 242   char *s;
 243   int slen;
 244   SCM line, term;
 245
 246   if (SCM_UNBNDP (port))
 247     port = scm_cur_inp;
 248   SCM_VALIDATE_OPINPORT (1,port);
 249
 250   pt = SCM_PTAB_ENTRY (port);
 251   if (pt->rw_active == SCM_PORT_WRITE)
 252     scm_ptobs[SCM_PTOBNUM (port)].flush (port);
 253
 254   s = scm_do_read_line (port, &slen);
 255
 256   if (s == NULL)
 257     term = line = SCM_EOF_VAL;
 258   else
 259     {
 260       if (s[slen-1] == '\n')
 261         {
 262           term = SCM_MAKE_CHAR ('\n');
 263           s[slen-1] = '\0';
 264           line = scm_take_str (s, slen-1);
 265           scm_done_malloc (-1);
 266           SCM_INCLINE (port);
 267         }
 268       else
 269         {
 270           /* Fix: we should check for eof on the port before assuming this. */
 271           term = SCM_EOF_VAL;
 272           line = scm_take_str (s, slen);
 273           SCM_COL (port) += slen;
 274         }
 275     }
 276
 277   if (pt->rw_random)
 278     pt->rw_active = SCM_PORT_READ;
 279
 280   return scm_cons (line, term);
 281 }
 282 #undef FUNC_NAME
 283
 284 SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0,
 285             (SCM obj, SCM port),
 286             "Display @var{obj} and a newline character to @var{port}.  If @var{port}\n"
 287             "is not specified, @code{(current-output-port)} is used.  This function\n"
 288             "is equivalent to:\n\n"
 289             "@smalllisp\n"
 290             "(display obj [port])\n"
 291             "(newline [port])\n"
 292             "@end smalllisp")
 293 #define FUNC_NAME s_scm_write_line
 294 {
 295   scm_display (obj, port);
 296   return scm_newline (port);
 297 }
 298 #undef FUNC_NAME
 299
 300 SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
 301             (SCM object),
 302             "Returns an integer representing the current position of @var{fd/port},\n"
 303             "measured from the beginning.  Equivalent to:\n"
 304             "@smalllisp\n"
 305             "(seek port 0 SEEK_CUR)\n"
 306             "@end smalllisp")
 307 #define FUNC_NAME s_scm_ftell
 308 {
 309   return scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
 310 }
 311 #undef FUNC_NAME
 312
 313 SCM_DEFINE (scm_fseek, "fseek", 3, 0, 0,
 314             (SCM object, SCM offset, SCM whence),
 315             "Obsolete.  Almost the same as seek, above, but the return value is\n"
 316             "unspecified.")
 317 #define FUNC_NAME s_scm_fseek
 318 {
 319   scm_seek (object, offset, whence);
 320   return SCM_UNSPECIFIED;
 321 }
 322 #undef FUNC_NAME
 323
 324 SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
 325             (SCM old, SCM new),
 326             "This procedure takes two ports and duplicates the underlying file\n"
 327             "descriptor from @var{old-port} into @var{new-port}.  The\n"
 328             "current file descriptor in @var{new-port} will be closed.\n"
 329             "After the redirection the two ports will share a file position\n"
 330             "and file status flags.\n\n"
 331             "The return value is unspecified.\n\n"
 332             "Unexpected behaviour can result if both ports are subsequently used\n"
 333             "and the original and/or duplicate ports are buffered.\n\n"
 334             "This procedure does not have any side effects on other ports or\n"
 335             "revealed counts.")
 336 #define FUNC_NAME s_scm_redirect_port
 337 {
 338   int ans, oldfd, newfd;
 339   struct scm_fport *fp;
 340
 341   old = SCM_COERCE_OUTPORT (old);
 342   new = SCM_COERCE_OUTPORT (new);
 343
 344   SCM_VALIDATE_OPFPORT (1,old);
 345   SCM_VALIDATE_OPFPORT (2,new);
 346   oldfd = SCM_FPORT_FDES (old);
 347   fp = SCM_FSTREAM (new);
 348   newfd = fp->fdes;
 349   if (oldfd != newfd)
 350     {
 351       scm_port *pt = SCM_PTAB_ENTRY (new);
 352       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 353       scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 354
 355       /* must flush to old fdes.  */
 356       if (pt->rw_active == SCM_PORT_WRITE)
 357         ptob->flush (new);
 358       else if (pt->rw_active == SCM_PORT_READ)
 359         scm_end_input (new);
 360       ans = dup2 (oldfd, newfd);
 361       if (ans == -1)
 362         SCM_SYSERROR;
 363       pt->rw_random = old_pt->rw_random;
 364       /* continue using existing buffers, even if inappropriate.  */
 365     }
 366   return SCM_UNSPECIFIED;
 367 }
 368 #undef FUNC_NAME
 369
 370 SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 371             (SCM fd_or_port, SCM fd),
 372             "Returns an integer file descriptor.")
 373 #define FUNC_NAME s_scm_dup_to_fdes
 374 {
 375   int oldfd, newfd, rv;
 376
 377   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 378
 379   if (SCM_INUMP (fd_or_port))
 380     oldfd = SCM_INUM (fd_or_port);
 381   else
 382     {
 383       SCM_VALIDATE_OPFPORT (1,fd_or_port);
 384       oldfd = SCM_FPORT_FDES (fd_or_port);
 385     }
 386
 387   if (SCM_UNBNDP (fd))
 388     {
 389       newfd = dup (oldfd);
 390       if (newfd == -1)
 391         SCM_SYSERROR;
 392       fd = SCM_MAKINUM (newfd);
 393     }
 394   else
 395     {
 396       SCM_VALIDATE_INUM_COPY (2, fd, newfd);
 397       if (oldfd != newfd)
 398         {
 399           scm_evict_ports (newfd);      /* see scsh manual.  */
 400           rv = dup2 (oldfd, newfd);
 401           if (rv == -1)
 402             SCM_SYSERROR;
 403         }
 404     }
 405   return fd;
 406 }
 407 #undef FUNC_NAME
 408
 409 SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
 410             (SCM port),
 411             "Returns the integer file descriptor underlying @var{port}.\n"
 412             "Does not change its revealed count.")
 413 #define FUNC_NAME s_scm_fileno
 414 {
 415   port = SCM_COERCE_OUTPORT (port);
 416   SCM_VALIDATE_OPFPORT (1,port);
 417   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 418 }
 419 #undef FUNC_NAME
 420
 421 /* GJB:FIXME:: why does this not throw
 422    an error if the arg is not a port?
 423    This proc as is would be better names isattyport?
 424    if it is not going to assume that the arg is a port */
 425 SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
 426             (SCM port),
 427             "Returns @code{#t} if @var{port} is using a serial\n"
 428             "non-file device, otherwise @code{#f}.")
 429 #define FUNC_NAME s_scm_isatty_p
 430 {
 431   int rv;
 432
 433   port = SCM_COERCE_OUTPORT (port);
 434
 435   if (!SCM_OPFPORTP (port))
 436     return SCM_BOOL_F;
 437
 438   rv = isatty (SCM_FPORT_FDES (port));
 439   return  SCM_BOOL(rv);
 440 }
 441 #undef FUNC_NAME
 442
 443
 444
 445 SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
 446             (SCM fdes, SCM modes),
 447             "Returns a new port based on the file descriptor @var{fdes}.\n"
 448             "Modes are given by the string @var{modes}.  The revealed count of the port\n"
 449             "is initialized to zero.  The modes string is the same as that accepted\n"
 450             "by @ref{File Ports, open-file}.")
 451 #define FUNC_NAME s_scm_fdopen
 452 {
 453   SCM_VALIDATE_INUM (1,fdes);
 454   SCM_VALIDATE_ROSTRING (2,modes);
 455   SCM_COERCE_SUBSTR (modes);
 456
 457   return scm_fdes_to_port (SCM_INUM (fdes), SCM_ROCHARS (modes), SCM_BOOL_F);
 458 }
 459 #undef FUNC_NAME
 460
 461
 462
 463 /* Move a port's underlying file descriptor to a given value.
 464  * Returns  #f if fdes is already the given value.
 465  *          #t if fdes moved.
 466  * MOVE->FDES is implemented in Scheme and calls this primitive.
 467  */
 468 SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
 469             (SCM port, SCM fd),
 470             "Moves the underlying file descriptor for @var{port} to the integer\n"
 471             "value @var{fdes} without changing the revealed count of @var{port}.\n"
 472             "Any other ports already using this descriptor will be automatically\n"
 473             "shifted to new descriptors and their revealed counts reset to zero.\n"
 474             "The return value is @code{#f} if the file descriptor already had the\n"
 475             "required value or @code{#t} if it was moved.")
 476 #define FUNC_NAME s_scm_primitive_move_to_fdes
 477 {
 478   struct scm_fport *stream;
 479   int old_fd;
 480   int new_fd;
 481   int rv;
 482
 483   port = SCM_COERCE_OUTPORT (port);
 484
 485   SCM_VALIDATE_OPFPORT (1,port);
 486   SCM_VALIDATE_INUM (2,fd);
 487   stream = SCM_FSTREAM (port);
 488   old_fd = stream->fdes;
 489   new_fd = SCM_INUM (fd);
 490   if  (old_fd == new_fd)
 491     {
 492       return SCM_BOOL_F;
 493     }
 494   scm_evict_ports (new_fd);
 495   rv = dup2 (old_fd, new_fd);
 496   if (rv == -1)
 497     SCM_SYSERROR;
 498   stream->fdes = new_fd;
 499   SCM_SYSCALL (close (old_fd));
 500   return SCM_BOOL_T;
 501 }
 502 #undef FUNC_NAME
 503
 504 /* Return a list of ports using a given file descriptor.  */
 505 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 506            (SCM fd),
 507             "Returns a list of existing ports which have @var{fdes} as an\n"
 508             "underlying file descriptor, without changing their revealed counts.")
 509 #define FUNC_NAME s_scm_fdes_to_ports
 510 {
 511   SCM result = SCM_EOL;
 512   int int_fd;
 513   int i;
 514
 515   SCM_VALIDATE_INUM_COPY (1,fd,int_fd);
 516
 517   for (i = 0; i < scm_port_table_size; i++)
 518     {
 519       if (SCM_OPFPORTP (scm_port_table[i]->port)
 520           && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 521         result = scm_cons (scm_port_table[i]->port, result);
 522     }
 523   return result;
 524 }
 525 #undef FUNC_NAME
 526
 527
 528 void
 529 scm_init_ioext ()
 530 {
 531   scm_add_feature ("i/o-extensions");
 532
 533 #include "ioext.x"
 534 }
 535
 536
 537 /*
 538   Local Variables:
 539   c-file-style: "gnu"
 540   End:
 541 */