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