libguile/ioext.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 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 #include <errno.h>
  48
  49 #include "libguile/_scm.h"
  50 #include "libguile/ioext.h"
  51 #include "libguile/fports.h"
  52 #include "libguile/feature.h"
  53 #include "libguile/ports.h"
  54 #include "libguile/root.h"
  55 #include "libguile/strings.h"
  56 #include "libguile/validate.h"
  57
  58 #include <fcntl.h>
  59
  60 #ifdef HAVE_STRING_H
  61 #include <string.h>
  62 #endif
  63 #ifdef HAVE_UNISTD_H
  64 #include <unistd.h>
  65 #endif
  66 \f
  67
  68 #if defined (EAGAIN)
  69 #define SCM_MAYBE_EAGAIN || errno == EAGAIN
  70 #else
  71 #define SCM_MAYBE_EAGAIN
  72 #endif
  73
  74 #if defined (EWOULDBLOCK)
  75 #define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK
  76 #else
  77 #define SCM_MAYBE_EWOULDBLOCK
  78 #endif
  79
  80 /* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK.  */
  81 #define SCM_EBLOCK(errno) \
  82    (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK)
  83
  84 SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
  85             (SCM str, SCM port_or_fdes, SCM start, SCM end),
  86             "Read characters from an fport or file descriptor into a\n"
  87             "string @var{str}.  This procedure is scsh-compatible\n"
  88             "and can efficiently read large strings.  It will:\n\n"
  89             "@itemize\n"
  90             "@item\n"
  91             "attempt to fill the entire string, unless the @var{start}\n"
  92             "and/or @var{end} arguments are supplied.  i.e., @var{start}\n"
  93             "defaults to 0 and @var{end} defaults to\n"
  94             "@code{(string-length str)}\n"
  95             "@item\n"
  96             "use the current input port if @var{port_or_fdes} is not\n"
  97             "supplied.\n"
  98             "@item\n"
  99             "read any characters that are currently available,\n"
 100             "without waiting for the rest (short reads are possible).\n\n"
 101             "@item\n"
 102             "wait for as long as it needs to for the first character to\n"
 103             "become available, unless the port is in non-blocking mode\n"
 104             "@item\n"
 105             "return @code{#f} if end-of-file is encountered before reading\n"
 106             "any characters, otherwise return the number of characters\n"
 107             "read.\n"
 108             "@item\n"
 109             "return 0 if the port is in non-blocking mode and no characters\n"
 110             "are immediately available.\n"
 111             "@item\n"
 112             "return 0 if the request is for 0 bytes, with no\n"
 113             "end-of-file check\n"
 114             "@end itemize")
 115 #define FUNC_NAME s_scm_read_string_x_partial
 116 {
 117   char *dest;
 118   long read_len;
 119   long chars_read = 0;
 120   int fdes;
 121
 122   {
 123     long offset;
 124     long last;
 125
 126     SCM_VALIDATE_SUBSTRING_SPEC_COPY (1, str, dest, 3, start, offset,
 127                                       4, end, last);
 128     dest += offset;
 129     read_len = last - offset;
 130   }
 131
 132   if (SCM_INUMP (port_or_fdes))
 133     fdes = SCM_INUM (port_or_fdes);
 134   else
 135     {
 136       SCM port = SCM_UNBNDP (port_or_fdes) ? scm_cur_inp : port_or_fdes;
 137
 138       SCM_VALIDATE_OPFPORT (2, port);
 139       SCM_VALIDATE_INPUT_PORT (2, port);
 140
 141       /* if there's anything in the port buffers, use it, but then
 142          don't touch the file descriptor.  otherwise the
 143          "return immediately if something is available" rule may
 144          be violated.  */
 145       chars_read = scm_take_from_input_buffers (port, dest, read_len);
 146       fdes = SCM_FPORT_FDES (port);
 147     }
 148
 149   if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
 150                                           EOF.  */
 151     {
 152       SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
 153       if (chars_read == -1)
 154         {
 155           if (SCM_EBLOCK (errno))
 156             chars_read = 0;
 157           else
 158             SCM_SYSERROR;
 159         }
 160       else if (chars_read == 0)
 161         return SCM_BOOL_F;
 162     }
 163   return scm_long2num (chars_read);
 164 }
 165 #undef FUNC_NAME
 166
 167 SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
 168             (SCM fd_port),
 169             "Return an integer representing the current position of\n"
 170             "@var{fd/port}, measured from the beginning.  Equivalent to:\n"
 171             "\n"
 172             "@lisp\n"
 173             "(seek port 0 SEEK_CUR)\n"
 174             "@end lisp")
 175 #define FUNC_NAME s_scm_ftell
 176 {
 177   return scm_seek (fd_port, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
 178 }
 179 #undef FUNC_NAME
 180
 181 SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
 182             (SCM old, SCM new),
 183             "This procedure takes two ports and duplicates the underlying file\n"
 184             "descriptor from @var{old-port} into @var{new-port}.  The\n"
 185             "current file descriptor in @var{new-port} will be closed.\n"
 186             "After the redirection the two ports will share a file position\n"
 187             "and file status flags.\n\n"
 188             "The return value is unspecified.\n\n"
 189             "Unexpected behaviour can result if both ports are subsequently used\n"
 190             "and the original and/or duplicate ports are buffered.\n\n"
 191             "This procedure does not have any side effects on other ports or\n"
 192             "revealed counts.")
 193 #define FUNC_NAME s_scm_redirect_port
 194 {
 195   int ans, oldfd, newfd;
 196   struct scm_fport *fp;
 197
 198   old = SCM_COERCE_OUTPORT (old);
 199   new = SCM_COERCE_OUTPORT (new);
 200
 201   SCM_VALIDATE_OPFPORT (1,old);
 202   SCM_VALIDATE_OPFPORT (2,new);
 203   oldfd = SCM_FPORT_FDES (old);
 204   fp = SCM_FSTREAM (new);
 205   newfd = fp->fdes;
 206   if (oldfd != newfd)
 207     {
 208       scm_port *pt = SCM_PTAB_ENTRY (new);
 209       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 210       scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 211
 212       /* must flush to old fdes.  */
 213       if (pt->rw_active == SCM_PORT_WRITE)
 214         ptob->flush (new);
 215       else if (pt->rw_active == SCM_PORT_READ)
 216         scm_end_input (new);
 217       ans = dup2 (oldfd, newfd);
 218       if (ans == -1)
 219         SCM_SYSERROR;
 220       pt->rw_random = old_pt->rw_random;
 221       /* continue using existing buffers, even if inappropriate.  */
 222     }
 223   return SCM_UNSPECIFIED;
 224 }
 225 #undef FUNC_NAME
 226
 227 SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 228             (SCM fd_or_port, SCM fd),
 229             "Return a new integer file descriptor referring to the open file\n"
 230             "designated by @var{fd_or_port}, which must be either an open\n"
 231             "file port or a file descriptor.")
 232 #define FUNC_NAME s_scm_dup_to_fdes
 233 {
 234   int oldfd, newfd, rv;
 235
 236   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 237
 238   if (SCM_INUMP (fd_or_port))
 239     oldfd = SCM_INUM (fd_or_port);
 240   else
 241     {
 242       SCM_VALIDATE_OPFPORT (1,fd_or_port);
 243       oldfd = SCM_FPORT_FDES (fd_or_port);
 244     }
 245
 246   if (SCM_UNBNDP (fd))
 247     {
 248       newfd = dup (oldfd);
 249       if (newfd == -1)
 250         SCM_SYSERROR;
 251       fd = SCM_MAKINUM (newfd);
 252     }
 253   else
 254     {
 255       SCM_VALIDATE_INUM_COPY (2, fd, newfd);
 256       if (oldfd != newfd)
 257         {
 258           scm_evict_ports (newfd);      /* see scsh manual.  */
 259           rv = dup2 (oldfd, newfd);
 260           if (rv == -1)
 261             SCM_SYSERROR;
 262         }
 263     }
 264   return fd;
 265 }
 266 #undef FUNC_NAME
 267
 268
 269 SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
 270             (SCM oldfd, SCM newfd),
 271             "A simple wrapper for the @code{dup2} system call.\n"
 272             "Copies the file descriptor @var{oldfd} to descriptor\n"
 273             "number @var{newfd}, replacing the previous meaning\n"
 274             "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
 275             "be integers.\n"
 276             "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
 277             "is made to move away ports which are using @var{newfd}.\n"
 278             "The return value is unspecified.")
 279 #define FUNC_NAME s_scm_dup2
 280 {
 281   int c_oldfd;
 282   int c_newfd;
 283   int rv;
 284
 285   SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd);
 286   SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd);
 287   rv = dup2 (c_oldfd, c_newfd);
 288   if (rv == -1)
 289     SCM_SYSERROR;
 290   return SCM_UNSPECIFIED;
 291 }
 292 #undef FUNC_NAME
 293
 294 SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
 295             (SCM port),
 296             "Return the integer file descriptor underlying @var{port}.  Does\n"
 297             "not change its revealed count.")
 298 #define FUNC_NAME s_scm_fileno
 299 {
 300   port = SCM_COERCE_OUTPORT (port);
 301   SCM_VALIDATE_OPFPORT (1,port);
 302   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 303 }
 304 #undef FUNC_NAME
 305
 306 /* GJB:FIXME:: why does this not throw
 307    an error if the arg is not a port?
 308    This proc as is would be better names isattyport?
 309    if it is not going to assume that the arg is a port */
 310 SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
 311             (SCM port),
 312             "Return @code{#t} if @var{port} is using a serial non--file\n"
 313             "device, otherwise @code{#f}.")
 314 #define FUNC_NAME s_scm_isatty_p
 315 {
 316   int rv;
 317
 318   port = SCM_COERCE_OUTPORT (port);
 319
 320   if (!SCM_OPFPORTP (port))
 321     return SCM_BOOL_F;
 322
 323   rv = isatty (SCM_FPORT_FDES (port));
 324   return  SCM_BOOL(rv);
 325 }
 326 #undef FUNC_NAME
 327
 328
 329
 330 SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
 331             (SCM fdes, SCM modes),
 332             "Return a new port based on the file descriptor @var{fdes}.\n"
 333             "Modes are given by the string @var{modes}.  The revealed count\n"
 334             "of the port is initialized to zero.  The modes string is the\n"
 335             "same as that accepted by @ref{File Ports, open-file}.")
 336 #define FUNC_NAME s_scm_fdopen
 337 {
 338   SCM_VALIDATE_INUM (1,fdes);
 339   SCM_VALIDATE_STRING (2, modes);
 340   SCM_STRING_COERCE_0TERMINATION_X (modes);
 341
 342   return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F);
 343 }
 344 #undef FUNC_NAME
 345
 346
 347
 348 /* Move a port's underlying file descriptor to a given value.
 349  * Returns  #f if fdes is already the given value.
 350  *          #t if fdes moved.
 351  * MOVE->FDES is implemented in Scheme and calls this primitive.
 352  */
 353 SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
 354             (SCM port, SCM fd),
 355             "Moves the underlying file descriptor for @var{port} to the integer\n"
 356             "value @var{fdes} without changing the revealed count of @var{port}.\n"
 357             "Any other ports already using this descriptor will be automatically\n"
 358             "shifted to new descriptors and their revealed counts reset to zero.\n"
 359             "The return value is @code{#f} if the file descriptor already had the\n"
 360             "required value or @code{#t} if it was moved.")
 361 #define FUNC_NAME s_scm_primitive_move_to_fdes
 362 {
 363   struct scm_fport *stream;
 364   int old_fd;
 365   int new_fd;
 366   int rv;
 367
 368   port = SCM_COERCE_OUTPORT (port);
 369
 370   SCM_VALIDATE_OPFPORT (1,port);
 371   SCM_VALIDATE_INUM (2,fd);
 372   stream = SCM_FSTREAM (port);
 373   old_fd = stream->fdes;
 374   new_fd = SCM_INUM (fd);
 375   if  (old_fd == new_fd)
 376     {
 377       return SCM_BOOL_F;
 378     }
 379   scm_evict_ports (new_fd);
 380   rv = dup2 (old_fd, new_fd);
 381   if (rv == -1)
 382     SCM_SYSERROR;
 383   stream->fdes = new_fd;
 384   SCM_SYSCALL (close (old_fd));
 385   return SCM_BOOL_T;
 386 }
 387 #undef FUNC_NAME
 388
 389 /* Return a list of ports using a given file descriptor.  */
 390 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 391            (SCM fd),
 392             "Return a list of existing ports which have @var{fdes} as an\n"
 393             "underlying file descriptor, without changing their revealed\n"
 394             "counts.")
 395 #define FUNC_NAME s_scm_fdes_to_ports
 396 {
 397   SCM result = SCM_EOL;
 398   int int_fd;
 399   int i;
 400
 401   SCM_VALIDATE_INUM_COPY (1,fd,int_fd);
 402
 403   for (i = 0; i < scm_port_table_size; i++)
 404     {
 405       if (SCM_OPFPORTP (scm_port_table[i]->port)
 406           && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 407         result = scm_cons (scm_port_table[i]->port, result);
 408     }
 409   return result;
 410 }
 411 #undef FUNC_NAME
 412
 413
 414 void
 415 scm_init_ioext ()
 416 {
 417   scm_add_feature ("i/o-extensions");
 418
 419 #ifndef SCM_MAGIC_SNARFER
 420 #include "libguile/ioext.x"
 421 #endif
 422 }
 423
 424
 425 /*
 426   Local Variables:
 427   c-file-style: "gnu"
 428   End:
 429 */