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