libguile/ioext.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 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 "libguile/_scm.h"
  50 #include "libguile/ports.h"
  51 #include "libguile/read.h"
  52 #include "libguile/fports.h"
  53 #include "libguile/unif.h"
  54 #include "libguile/chars.h"
  55 #include "libguile/feature.h"
  56 #include "libguile/root.h"
  57 #include "libguile/strings.h"
  58
  59 #include "libguile/validate.h"
  60 #include "libguile/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_STRING_COPY (1, delims, cdelims);
  97   num_delims = SCM_STRING_LENGTH (delims);
  98   SCM_VALIDATE_STRING_COPY (2,buf,cbuf);
  99   cend = SCM_STRING_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 = (char *) 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
 314 #if (SCM_DEBUG_DEPRECATED == 0)
 315
 316 SCM_DEFINE (scm_fseek, "fseek", 3, 0, 0,
 317             (SCM object, SCM offset, SCM whence),
 318             "Obsolete.  Almost the same as seek, above, but the return value is\n"
 319             "unspecified.")
 320 #define FUNC_NAME s_scm_fseek
 321 {
 322   scm_seek (object, offset, whence);
 323   return SCM_UNSPECIFIED;
 324 }
 325 #undef FUNC_NAME
 326
 327 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 328
 329
 330 SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
 331             (SCM old, SCM new),
 332             "This procedure takes two ports and duplicates the underlying file\n"
 333             "descriptor from @var{old-port} into @var{new-port}.  The\n"
 334             "current file descriptor in @var{new-port} will be closed.\n"
 335             "After the redirection the two ports will share a file position\n"
 336             "and file status flags.\n\n"
 337             "The return value is unspecified.\n\n"
 338             "Unexpected behaviour can result if both ports are subsequently used\n"
 339             "and the original and/or duplicate ports are buffered.\n\n"
 340             "This procedure does not have any side effects on other ports or\n"
 341             "revealed counts.")
 342 #define FUNC_NAME s_scm_redirect_port
 343 {
 344   int ans, oldfd, newfd;
 345   struct scm_fport *fp;
 346
 347   old = SCM_COERCE_OUTPORT (old);
 348   new = SCM_COERCE_OUTPORT (new);
 349
 350   SCM_VALIDATE_OPFPORT (1,old);
 351   SCM_VALIDATE_OPFPORT (2,new);
 352   oldfd = SCM_FPORT_FDES (old);
 353   fp = SCM_FSTREAM (new);
 354   newfd = fp->fdes;
 355   if (oldfd != newfd)
 356     {
 357       scm_port *pt = SCM_PTAB_ENTRY (new);
 358       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 359       scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 360
 361       /* must flush to old fdes.  */
 362       if (pt->rw_active == SCM_PORT_WRITE)
 363         ptob->flush (new);
 364       else if (pt->rw_active == SCM_PORT_READ)
 365         scm_end_input (new);
 366       ans = dup2 (oldfd, newfd);
 367       if (ans == -1)
 368         SCM_SYSERROR;
 369       pt->rw_random = old_pt->rw_random;
 370       /* continue using existing buffers, even if inappropriate.  */
 371     }
 372   return SCM_UNSPECIFIED;
 373 }
 374 #undef FUNC_NAME
 375
 376 SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 377             (SCM fd_or_port, SCM fd),
 378             "Returns an integer file descriptor.")
 379 #define FUNC_NAME s_scm_dup_to_fdes
 380 {
 381   int oldfd, newfd, rv;
 382
 383   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 384
 385   if (SCM_INUMP (fd_or_port))
 386     oldfd = SCM_INUM (fd_or_port);
 387   else
 388     {
 389       SCM_VALIDATE_OPFPORT (1,fd_or_port);
 390       oldfd = SCM_FPORT_FDES (fd_or_port);
 391     }
 392
 393   if (SCM_UNBNDP (fd))
 394     {
 395       newfd = dup (oldfd);
 396       if (newfd == -1)
 397         SCM_SYSERROR;
 398       fd = SCM_MAKINUM (newfd);
 399     }
 400   else
 401     {
 402       SCM_VALIDATE_INUM_COPY (2, fd, newfd);
 403       if (oldfd != newfd)
 404         {
 405           scm_evict_ports (newfd);      /* see scsh manual.  */
 406           rv = dup2 (oldfd, newfd);
 407           if (rv == -1)
 408             SCM_SYSERROR;
 409         }
 410     }
 411   return fd;
 412 }
 413 #undef FUNC_NAME
 414
 415
 416 SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
 417             (SCM oldfd, SCM newfd),
 418             "A simple wrapper for the @code{dup2} system call.\n"
 419             "Copies the file descriptor @var{oldfd} to descriptor\n"
 420             "number @var{newfd}, replacing the previous meaning\n"
 421             "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
 422             "be integers.\n"
 423             "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
 424             "is made to move away ports which are using @var{newfd}.\n"
 425             "The return value is unspecified.")
 426 #define FUNC_NAME s_scm_dup2
 427 {
 428   int c_oldfd;
 429   int c_newfd;
 430   int rv;
 431
 432   SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd);
 433   SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd);
 434   rv = dup2 (c_oldfd, c_newfd);
 435   if (rv == -1)
 436     SCM_SYSERROR;
 437   return SCM_UNSPECIFIED;
 438 }
 439 #undef FUNC_NAME
 440
 441 SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
 442             (SCM port),
 443             "Returns the integer file descriptor underlying @var{port}.\n"
 444             "Does not change its revealed count.")
 445 #define FUNC_NAME s_scm_fileno
 446 {
 447   port = SCM_COERCE_OUTPORT (port);
 448   SCM_VALIDATE_OPFPORT (1,port);
 449   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 450 }
 451 #undef FUNC_NAME
 452
 453 /* GJB:FIXME:: why does this not throw
 454    an error if the arg is not a port?
 455    This proc as is would be better names isattyport?
 456    if it is not going to assume that the arg is a port */
 457 SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
 458             (SCM port),
 459             "Returns @code{#t} if @var{port} is using a serial\n"
 460             "non-file device, otherwise @code{#f}.")
 461 #define FUNC_NAME s_scm_isatty_p
 462 {
 463   int rv;
 464
 465   port = SCM_COERCE_OUTPORT (port);
 466
 467   if (!SCM_OPFPORTP (port))
 468     return SCM_BOOL_F;
 469
 470   rv = isatty (SCM_FPORT_FDES (port));
 471   return  SCM_BOOL(rv);
 472 }
 473 #undef FUNC_NAME
 474
 475
 476
 477 SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
 478             (SCM fdes, SCM modes),
 479             "Returns a new port based on the file descriptor @var{fdes}.\n"
 480             "Modes are given by the string @var{modes}.  The revealed count of the port\n"
 481             "is initialized to zero.  The modes string is the same as that accepted\n"
 482             "by @ref{File Ports, open-file}.")
 483 #define FUNC_NAME s_scm_fdopen
 484 {
 485   SCM_VALIDATE_INUM (1,fdes);
 486   SCM_VALIDATE_STRING (2, modes);
 487   SCM_STRING_COERCE_0TERMINATION_X (modes);
 488
 489   return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F);
 490 }
 491 #undef FUNC_NAME
 492
 493
 494
 495 /* Move a port's underlying file descriptor to a given value.
 496  * Returns  #f if fdes is already the given value.
 497  *          #t if fdes moved.
 498  * MOVE->FDES is implemented in Scheme and calls this primitive.
 499  */
 500 SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
 501             (SCM port, SCM fd),
 502             "Moves the underlying file descriptor for @var{port} to the integer\n"
 503             "value @var{fdes} without changing the revealed count of @var{port}.\n"
 504             "Any other ports already using this descriptor will be automatically\n"
 505             "shifted to new descriptors and their revealed counts reset to zero.\n"
 506             "The return value is @code{#f} if the file descriptor already had the\n"
 507             "required value or @code{#t} if it was moved.")
 508 #define FUNC_NAME s_scm_primitive_move_to_fdes
 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_VALIDATE_OPFPORT (1,port);
 518   SCM_VALIDATE_INUM (2,fd);
 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;
 530   stream->fdes = new_fd;
 531   SCM_SYSCALL (close (old_fd));
 532   return SCM_BOOL_T;
 533 }
 534 #undef FUNC_NAME
 535
 536 /* Return a list of ports using a given file descriptor.  */
 537 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 538            (SCM fd),
 539             "Returns a list of existing ports which have @var{fdes} as an\n"
 540             "underlying file descriptor, without changing their revealed counts.")
 541 #define FUNC_NAME s_scm_fdes_to_ports
 542 {
 543   SCM result = SCM_EOL;
 544   int int_fd;
 545   int i;
 546
 547   SCM_VALIDATE_INUM_COPY (1,fd,int_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 #undef FUNC_NAME
 558
 559
 560 void
 561 scm_init_ioext ()
 562 {
 563   scm_add_feature ("i/o-extensions");
 564
 565 #ifndef SCM_MAGIC_SNARFER
 566 #include "libguile/ioext.x"
 567 #endif
 568 }
 569
 570
 571 /*
 572   Local Variables:
 573   c-file-style: "gnu"
 574   End:
 575 */