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 object),
 169             "Returns an integer representing the current position of @var{fd/port},\n"
 170             "measured from the beginning.  Equivalent to:\n"
 171             "@smalllisp\n"
 172             "(seek port 0 SEEK_CUR)\n"
 173             "@end smalllisp")
 174 #define FUNC_NAME s_scm_ftell
 175 {
 176   return scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR));
 177 }
 178 #undef FUNC_NAME
 179
 180
 181 #if (SCM_DEBUG_DEPRECATED == 0)
 182
 183 SCM_DEFINE (scm_fseek, "fseek", 3, 0, 0,
 184             (SCM object, SCM offset, SCM whence),
 185             "Obsolete.  Almost the same as seek, above, but the return value is\n"
 186             "unspecified.")
 187 #define FUNC_NAME s_scm_fseek
 188 {
 189   scm_seek (object, offset, whence);
 190   return SCM_UNSPECIFIED;
 191 }
 192 #undef FUNC_NAME
 193
 194 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 195
 196
 197 SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
 198             (SCM old, SCM new),
 199             "This procedure takes two ports and duplicates the underlying file\n"
 200             "descriptor from @var{old-port} into @var{new-port}.  The\n"
 201             "current file descriptor in @var{new-port} will be closed.\n"
 202             "After the redirection the two ports will share a file position\n"
 203             "and file status flags.\n\n"
 204             "The return value is unspecified.\n\n"
 205             "Unexpected behaviour can result if both ports are subsequently used\n"
 206             "and the original and/or duplicate ports are buffered.\n\n"
 207             "This procedure does not have any side effects on other ports or\n"
 208             "revealed counts.")
 209 #define FUNC_NAME s_scm_redirect_port
 210 {
 211   int ans, oldfd, newfd;
 212   struct scm_fport *fp;
 213
 214   old = SCM_COERCE_OUTPORT (old);
 215   new = SCM_COERCE_OUTPORT (new);
 216
 217   SCM_VALIDATE_OPFPORT (1,old);
 218   SCM_VALIDATE_OPFPORT (2,new);
 219   oldfd = SCM_FPORT_FDES (old);
 220   fp = SCM_FSTREAM (new);
 221   newfd = fp->fdes;
 222   if (oldfd != newfd)
 223     {
 224       scm_port *pt = SCM_PTAB_ENTRY (new);
 225       scm_port *old_pt = SCM_PTAB_ENTRY (old);
 226       scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
 227
 228       /* must flush to old fdes.  */
 229       if (pt->rw_active == SCM_PORT_WRITE)
 230         ptob->flush (new);
 231       else if (pt->rw_active == SCM_PORT_READ)
 232         scm_end_input (new);
 233       ans = dup2 (oldfd, newfd);
 234       if (ans == -1)
 235         SCM_SYSERROR;
 236       pt->rw_random = old_pt->rw_random;
 237       /* continue using existing buffers, even if inappropriate.  */
 238     }
 239   return SCM_UNSPECIFIED;
 240 }
 241 #undef FUNC_NAME
 242
 243 SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
 244             (SCM fd_or_port, SCM fd),
 245             "Returns an integer file descriptor.")
 246 #define FUNC_NAME s_scm_dup_to_fdes
 247 {
 248   int oldfd, newfd, rv;
 249
 250   fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
 251
 252   if (SCM_INUMP (fd_or_port))
 253     oldfd = SCM_INUM (fd_or_port);
 254   else
 255     {
 256       SCM_VALIDATE_OPFPORT (1,fd_or_port);
 257       oldfd = SCM_FPORT_FDES (fd_or_port);
 258     }
 259
 260   if (SCM_UNBNDP (fd))
 261     {
 262       newfd = dup (oldfd);
 263       if (newfd == -1)
 264         SCM_SYSERROR;
 265       fd = SCM_MAKINUM (newfd);
 266     }
 267   else
 268     {
 269       SCM_VALIDATE_INUM_COPY (2, fd, newfd);
 270       if (oldfd != newfd)
 271         {
 272           scm_evict_ports (newfd);      /* see scsh manual.  */
 273           rv = dup2 (oldfd, newfd);
 274           if (rv == -1)
 275             SCM_SYSERROR;
 276         }
 277     }
 278   return fd;
 279 }
 280 #undef FUNC_NAME
 281
 282
 283 SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
 284             (SCM oldfd, SCM newfd),
 285             "A simple wrapper for the @code{dup2} system call.\n"
 286             "Copies the file descriptor @var{oldfd} to descriptor\n"
 287             "number @var{newfd}, replacing the previous meaning\n"
 288             "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
 289             "be integers.\n"
 290             "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
 291             "is made to move away ports which are using @var{newfd}.\n"
 292             "The return value is unspecified.")
 293 #define FUNC_NAME s_scm_dup2
 294 {
 295   int c_oldfd;
 296   int c_newfd;
 297   int rv;
 298
 299   SCM_VALIDATE_INUM_COPY (1, oldfd, c_oldfd);
 300   SCM_VALIDATE_INUM_COPY (2, newfd, c_newfd);
 301   rv = dup2 (c_oldfd, c_newfd);
 302   if (rv == -1)
 303     SCM_SYSERROR;
 304   return SCM_UNSPECIFIED;
 305 }
 306 #undef FUNC_NAME
 307
 308 SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
 309             (SCM port),
 310             "Returns the integer file descriptor underlying @var{port}.\n"
 311             "Does not change its revealed count.")
 312 #define FUNC_NAME s_scm_fileno
 313 {
 314   port = SCM_COERCE_OUTPORT (port);
 315   SCM_VALIDATE_OPFPORT (1,port);
 316   return SCM_MAKINUM (SCM_FPORT_FDES (port));
 317 }
 318 #undef FUNC_NAME
 319
 320 /* GJB:FIXME:: why does this not throw
 321    an error if the arg is not a port?
 322    This proc as is would be better names isattyport?
 323    if it is not going to assume that the arg is a port */
 324 SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
 325             (SCM port),
 326             "Returns @code{#t} if @var{port} is using a serial\n"
 327             "non-file device, otherwise @code{#f}.")
 328 #define FUNC_NAME s_scm_isatty_p
 329 {
 330   int rv;
 331
 332   port = SCM_COERCE_OUTPORT (port);
 333
 334   if (!SCM_OPFPORTP (port))
 335     return SCM_BOOL_F;
 336
 337   rv = isatty (SCM_FPORT_FDES (port));
 338   return  SCM_BOOL(rv);
 339 }
 340 #undef FUNC_NAME
 341
 342
 343
 344 SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
 345             (SCM fdes, SCM modes),
 346             "Returns a new port based on the file descriptor @var{fdes}.\n"
 347             "Modes are given by the string @var{modes}.  The revealed count of the port\n"
 348             "is initialized to zero.  The modes string is the same as that accepted\n"
 349             "by @ref{File Ports, open-file}.")
 350 #define FUNC_NAME s_scm_fdopen
 351 {
 352   SCM_VALIDATE_INUM (1,fdes);
 353   SCM_VALIDATE_STRING (2, modes);
 354   SCM_STRING_COERCE_0TERMINATION_X (modes);
 355
 356   return scm_fdes_to_port (SCM_INUM (fdes), SCM_STRING_CHARS (modes), SCM_BOOL_F);
 357 }
 358 #undef FUNC_NAME
 359
 360
 361
 362 /* Move a port's underlying file descriptor to a given value.
 363  * Returns  #f if fdes is already the given value.
 364  *          #t if fdes moved.
 365  * MOVE->FDES is implemented in Scheme and calls this primitive.
 366  */
 367 SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
 368             (SCM port, SCM fd),
 369             "Moves the underlying file descriptor for @var{port} to the integer\n"
 370             "value @var{fdes} without changing the revealed count of @var{port}.\n"
 371             "Any other ports already using this descriptor will be automatically\n"
 372             "shifted to new descriptors and their revealed counts reset to zero.\n"
 373             "The return value is @code{#f} if the file descriptor already had the\n"
 374             "required value or @code{#t} if it was moved.")
 375 #define FUNC_NAME s_scm_primitive_move_to_fdes
 376 {
 377   struct scm_fport *stream;
 378   int old_fd;
 379   int new_fd;
 380   int rv;
 381
 382   port = SCM_COERCE_OUTPORT (port);
 383
 384   SCM_VALIDATE_OPFPORT (1,port);
 385   SCM_VALIDATE_INUM (2,fd);
 386   stream = SCM_FSTREAM (port);
 387   old_fd = stream->fdes;
 388   new_fd = SCM_INUM (fd);
 389   if  (old_fd == new_fd)
 390     {
 391       return SCM_BOOL_F;
 392     }
 393   scm_evict_ports (new_fd);
 394   rv = dup2 (old_fd, new_fd);
 395   if (rv == -1)
 396     SCM_SYSERROR;
 397   stream->fdes = new_fd;
 398   SCM_SYSCALL (close (old_fd));
 399   return SCM_BOOL_T;
 400 }
 401 #undef FUNC_NAME
 402
 403 /* Return a list of ports using a given file descriptor.  */
 404 SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
 405            (SCM fd),
 406             "Returns a list of existing ports which have @var{fdes} as an\n"
 407             "underlying file descriptor, without changing their revealed counts.")
 408 #define FUNC_NAME s_scm_fdes_to_ports
 409 {
 410   SCM result = SCM_EOL;
 411   int int_fd;
 412   int i;
 413
 414   SCM_VALIDATE_INUM_COPY (1,fd,int_fd);
 415
 416   for (i = 0; i < scm_port_table_size; i++)
 417     {
 418       if (SCM_OPFPORTP (scm_port_table[i]->port)
 419           && ((struct scm_fport *) scm_port_table[i]->stream)->fdes == int_fd)
 420         result = scm_cons (scm_port_table[i]->port, result);
 421     }
 422   return result;
 423 }
 424 #undef FUNC_NAME
 425
 426
 427 void
 428 scm_init_ioext ()
 429 {
 430   scm_add_feature ("i/o-extensions");
 431
 432 #ifndef SCM_MAGIC_SNARFER
 433 #include "libguile/ioext.x"
 434 #endif
 435 }
 436
 437
 438 /*
 439   Local Variables:
 440   c-file-style: "gnu"
 441   End:
 442 */