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
  43 \f
  44
  45 #include <stdio.h>
  46 #include <errno.h>
  47
  48 #include "libguile/_scm.h"
  49 #include "libguile/ioext.h"
  50 #include "libguile/fports.h"
  51 #include "libguile/feature.h"
  52 #include "libguile/ports.h"
  53 #include "libguile/strings.h"
  54 #include "libguile/validate.h"
  55
  56 #include <fcntl.h>
  57
  58 #ifdef HAVE_UNISTD_H
  59 #include <unistd.h>
  60 #endif
  61 \f
  62
  63 SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
  64             (SCM fd_port),
  65             "Return an integer representing the current position of\n"
  66             "@var{fd/port}, measured from the beginning.  Equivalent to:\n"
  67             "\n"
  68             "@lisp\n"
  69             "(seek port 0 SEEK_CUR)\n"
  70             "@end lisp")
  71 #define FUNC_NAME s_scm_ftell
  72 {
  73   return scm_seek (fd_port, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
  74 }
  75 #undef FUNC_NAME
  76
  77 SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
  78             (SCM old, SCM new),
  79             "This procedure takes two ports and duplicates the underlying file\n"
  80             "descriptor from @var{old-port} into @var{new-port}.  The\n"
  81             "current file descriptor in @var{new-port} will be closed.\n"
  82             "After the redirection the two ports will share a file position\n"
  83             "and file status flags.\n\n"
  84             "The return value is unspecified.\n\n"
  85             "Unexpected behaviour can result if both ports are subsequently used\n"
  86             "and the original and/or duplicate ports are buffered.\n\n"
  87             "This procedure does not have any side effects on other ports or\n"
  88             "revealed counts.")
  89 #define FUNC_NAME s_scm_redirect_port
  90 {
  91   int ans, oldfd, newfd;
  92   scm_t_fport *fp;
  93
  94   old = SCM_COERCE_OUTPORT (old);
  95   new = SCM_COERCE_OUTPORT (new);
  96
  97   SCM_VALIDATE_OPFPORT (1,old);
  98   SCM_VALIDATE_OPFPORT (2,new);
  99   oldfd = SCM_FPORT_FDES (old);
 100   fp = SCM_FSTREAM (new);
 101   newfd = fp->fdes;
 102   if (oldfd != newfd)
 103     {
 104       scm_t_port *pt = SCM_PTAB_ENTRY (new);
 105       scm_t_port *old_pt = SCM_PTAB_ENTRY (old);
 106       scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 107
 108       /* must flush to old fdes.  */
 109       if (pt->rw_active == SCM_PORT_WRITE)
 110         ptob->flush (new);
 111       else if (pt->rw_active == SCM_PORT_READ)
 112         scm_end_input (new);
 113       ans = dup2 (oldfd, newfd);
 114       if (ans == -1)
 115         SCM_SYSERROR;
 116       pt->rw_random = old_pt->rw_random;
 117       /* continue using existing buffers, even if inappropriate.  */
 118     }
 119   return SCM_UNSPECIFIED;
 120 }
 121 #undef FUNC_NAME
 122
 123 SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 124             (SCM fd_or_port, SCM fd),
 125             "Return a new integer file descriptor referring to the open file\n"
 126             "designated by @var{fd_or_port}, which must be either an open\n"
 127             "file port or a file descriptor.")
 128 #define FUNC_NAME s_scm_dup_to_fdes
 129 {
 130   int oldfd, newfd, rv;
 131
 132   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 133
 134   if (SCM_INUMP (fd_or_port))
 135     oldfd = SCM_INUM (fd_or_port);
 136   else
 137     {
 138       SCM_VALIDATE_OPFPORT (1,fd_or_port);
 139       oldfd = SCM_FPORT_FDES (fd_or_port);
 140     }
 141
 142   if (SCM_UNBNDP (fd))
 143     {
 144       newfd = dup (oldfd);
 145       if (newfd == -1)
 146         SCM_SYSERROR;
 147       fd = SCM_MAKINUM (newfd);
 148     }
 149   else
 150     {
 151       SCM_VALIDATE_INUM_COPY (2, fd, newfd);
 152       if (oldfd != newfd)
 153         {
 154           scm_evict_ports (newfd);      /* see scsh manual.  */
 155           rv = dup2 (oldfd, newfd);
 156           if (rv == -1)
 157             SCM_SYSERROR;
 158         }
 159     }
 160   return fd;
 161 }
 162 #undef FUNC_NAME
 163
 164
 165 SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
 166             (SCM oldfd, SCM newfd),
 167             "A simple wrapper for the @code{dup2} system call.\n"
 168             "Copies the file descriptor @var{oldfd} to descriptor\n"
 169             "number @var{newfd}, replacing the previous meaning\n"
 170             "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
 171             "be integers.\n"
 172             "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
 173             "is made to move away ports which are using @var{newfd}.\n"
 174             "The return value is unspecified.")
 175 #define FUNC_NAME s_scm_dup2
 176 {
 177   int c_oldfd;
 178   int c_newfd;
 179   int rv;
 180
 181   SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd);
 182   SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd);
 183   rv = dup2 (c_oldfd, c_newfd);
 184   if (rv == -1)
 185     SCM_SYSERROR;
 186   return SCM_UNSPECIFIED;
 187 }
 188 #undef FUNC_NAME
 189
 190 SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
 191             (SCM port),
 192             "Return the integer file descriptor underlying @var{port}.  Does\n"
 193             "not change its revealed count.")
 194 #define FUNC_NAME s_scm_fileno
 195 {
 196   port = SCM_COERCE_OUTPORT (port);
 197   SCM_VALIDATE_OPFPORT (1,port);
 198   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 199 }
 200 #undef FUNC_NAME
 201
 202 /* GJB:FIXME:: why does this not throw
 203    an error if the arg is not a port?
 204    This proc as is would be better names isattyport?
 205    if it is not going to assume that the arg is a port
 206
 207    [cmm] I don't see any problem with the above.  why should a type
 208    predicate assume _anything_ about its argument?
 209 */
 210 SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
 211             (SCM port),
 212             "Return @code{#t} if @var{port} is using a serial non--file\n"
 213             "device, otherwise @code{#f}.")
 214 #define FUNC_NAME s_scm_isatty_p
 215 {
 216   int rv;
 217
 218   port = SCM_COERCE_OUTPORT (port);
 219
 220   if (!SCM_OPFPORTP (port))
 221     return SCM_BOOL_F;
 222
 223   rv = isatty (SCM_FPORT_FDES (port));
 224   return  SCM_BOOL(rv);
 225 }
 226 #undef FUNC_NAME
 227
 228
 229
 230 SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
 231             (SCM fdes, SCM modes),
 232             "Return a new port based on the file descriptor @var{fdes}.\n"
 233             "Modes are given by the string @var{modes}.  The revealed count\n"
 234             "of the port is initialized to zero.  The modes string is the\n"
 235             "same as that accepted by @ref{File Ports, open-file}.")
 236 #define FUNC_NAME s_scm_fdopen
 237 {
 238   SCM_VALIDATE_INUM (1,fdes);
 239   SCM_VALIDATE_STRING (2, modes);
 240
 241   return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F);
 242 }
 243 #undef FUNC_NAME
 244
 245
 246
 247 /* Move a port's underlying file descriptor to a given value.
 248  * Returns  #f if fdes is already the given value.
 249  *          #t if fdes moved.
 250  * MOVE->FDES is implemented in Scheme and calls this primitive.
 251  */
 252 SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
 253             (SCM port, SCM fd),
 254             "Moves the underlying file descriptor for @var{port} to the integer\n"
 255             "value @var{fdes} without changing the revealed count of @var{port}.\n"
 256             "Any other ports already using this descriptor will be automatically\n"
 257             "shifted to new descriptors and their revealed counts reset to zero.\n"
 258             "The return value is @code{#f} if the file descriptor already had the\n"
 259             "required value or @code{#t} if it was moved.")
 260 #define FUNC_NAME s_scm_primitive_move_to_fdes
 261 {
 262   scm_t_fport *stream;
 263   int old_fd;
 264   int new_fd;
 265   int rv;
 266
 267   port = SCM_COERCE_OUTPORT (port);
 268
 269   SCM_VALIDATE_OPFPORT (1,port);
 270   SCM_VALIDATE_INUM (2,fd);
 271   stream = SCM_FSTREAM (port);
 272   old_fd = stream->fdes;
 273   new_fd = SCM_INUM (fd);
 274   if  (old_fd == new_fd)
 275     {
 276       return SCM_BOOL_F;
 277     }
 278   scm_evict_ports (new_fd);
 279   rv = dup2 (old_fd, new_fd);
 280   if (rv == -1)
 281     SCM_SYSERROR;
 282   stream->fdes = new_fd;
 283   SCM_SYSCALL (close (old_fd));
 284   return SCM_BOOL_T;
 285 }
 286 #undef FUNC_NAME
 287
 288 /* Return a list of ports using a given file descriptor.  */
 289 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 290            (SCM fd),
 291             "Return a list of existing ports which have @var{fdes} as an\n"
 292             "underlying file descriptor, without changing their revealed\n"
 293             "counts.")
 294 #define FUNC_NAME s_scm_fdes_to_ports
 295 {
 296   SCM result = SCM_EOL;
 297   int int_fd;
 298   long i;
 299
 300   SCM_VALIDATE_INUM_COPY (1,fd,int_fd);
 301
 302   for (i = 0; i < scm_port_table_size; i++)
 303     {
 304       if (SCM_OPFPORTP (scm_port_table[i]->port)
 305           && ((scm_t_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 306         result = scm_cons (scm_port_table[i]->port, result);
 307     }
 308   return result;
 309 }
 310 #undef FUNC_NAME
 311
 312
 313 void
 314 scm_init_ioext ()
 315 {
 316   scm_add_feature ("i/o-extensions");
 317
 318 #ifndef SCM_MAGIC_SNARFER
 319 #include "libguile/ioext.x"
 320 #endif
 321 }
 322
 323
 324 /*
 325   Local Variables:
 326   c-file-style: "gnu"
 327   End:
 328 */