libguile/ioext.c

   1 /*      Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43
  44 #include <stdio.h>
  45 #include "fd.h"
  46 #include "_scm.h"
  47
  48 #ifdef HAVE_STRING_H
  49 #include <string.h>
  50 #endif
  51 #ifdef HAVE_UNISTD_H
  52 #include <unistd.h>
  53 #endif
  54 \f
  55
  56 SCM_PROC (s_sys_ftell, "ftell", 1, 0, 0, scm_sys_ftell);
  57 #ifdef __STDC__
  58 SCM
  59 scm_sys_ftell (SCM port)
  60 #else
  61 SCM
  62 scm_sys_ftell (port)
  63      SCM port;
  64 #endif
  65 {
  66   long pos;
  67   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell);
  68   SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port)));
  69   if (pos < 0)
  70     SCM_SYSERROR (s_sys_ftell);
  71   if (pos > 0 && SCM_CRDYP (port))
  72     pos--;
  73   return SCM_MAKINUM (pos);
  74 }
  75
  76
  77
  78 SCM_PROC (s_sys_fseek, "fseek", 3, 0, 0, scm_sys_fseek);
  79 #ifdef __STDC__
  80 SCM
  81 scm_sys_fseek (SCM port, SCM offset, SCM whence)
  82 #else
  83 SCM
  84 scm_sys_fseek (port, offset, whence)
  85      SCM port;
  86      SCM offset;
  87      SCM whence;
  88 #endif
  89 {
  90   int rv;
  91   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fseek);
  92   SCM_ASSERT (SCM_INUMP (offset), offset, SCM_ARG2, s_sys_fseek);
  93   SCM_ASSERT (SCM_INUMP (whence) && (SCM_INUM (whence) < 3) && (SCM_INUM (whence) >= 0),
  94           whence, SCM_ARG3, s_sys_fseek);
  95   SCM_CLRDY (port);                     /* Clear ungetted char */
  96   /* Values of whence are interned in scm_init_ioext.  */
  97   rv = fseek ((FILE *)SCM_STREAM (port), SCM_INUM (offset), SCM_INUM (whence));
  98   if (rv != 0)
  99     SCM_SYSERROR (s_sys_fseek);
 100   return SCM_UNSPECIFIED;
 101 }
 102
 103
 104
 105 SCM_PROC (s_sys_freopen, "freopen", 3, 0, 0, scm_sys_freopen);
 106 #ifdef __STDC__
 107 SCM
 108 scm_sys_freopen (SCM filename, SCM modes, SCM port)
 109 #else
 110 SCM
 111 scm_sys_freopen (filename, modes, port)
 112      SCM filename;
 113      SCM modes;
 114      SCM port;
 115 #endif
 116 {
 117   FILE *f;
 118   SCM_ASSERT (SCM_NIMP (filename) && SCM_STRINGP (filename), filename, SCM_ARG1, s_sys_freopen);
 119   SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_freopen);
 120   SCM_DEFER_INTS;
 121   SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_sys_freopen);
 122   SCM_SYSCALL (f = freopen (SCM_CHARS (filename), SCM_CHARS (modes), (FILE *)SCM_STREAM (port)));
 123   if (!f)
 124     {
 125       SCM p;
 126       p = port;
 127       port = SCM_MAKINUM (errno);
 128       SCM_CAR (p) &= ~SCM_OPN;
 129       scm_remove_from_port_table (p);
 130     }
 131   else
 132     {
 133       SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes));
 134       SCM_SETSTREAM (port, (SCM)f);
 135       if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))))
 136         scm_setbuf0 (port);
 137     }
 138   SCM_ALLOW_INTS;
 139   return port;
 140 }
 141
 142
 143
 144 SCM_PROC (s_sys_duplicate_port, "duplicate-port", 2, 0, 0, scm_sys_duplicate_port);
 145 #ifdef __STDC__
 146 SCM
 147 scm_sys_duplicate_port (SCM oldpt, SCM modes)
 148 #else
 149 SCM
 150 scm_sys_duplicate_port (oldpt, modes)
 151      SCM oldpt;
 152      SCM modes;
 153 #endif
 154 {
 155   int oldfd;
 156   int newfd;
 157   FILE *f;
 158   SCM newpt;
 159   SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1, s_sys_duplicate_port);
 160   SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_duplicate_port);
 161   SCM_NEWCELL (newpt);
 162   SCM_DEFER_INTS;
 163   oldfd = fileno ((FILE *)SCM_STREAM (oldpt));
 164   if (oldfd == -1)
 165     SCM_SYSERROR (s_sys_duplicate_port);
 166   SCM_SYSCALL (newfd = dup (oldfd));
 167   if (newfd == -1)
 168     SCM_SYSERROR (s_sys_duplicate_port);
 169   f = fdopen (newfd, SCM_CHARS (modes));
 170   if (!f)
 171     {
 172       SCM_SYSCALL (close (newfd));
 173       SCM_SYSERROR (s_sys_duplicate_port);
 174     }
 175   {
 176     struct scm_port_table * pt;
 177     pt = scm_add_to_port_table (newpt);
 178     SCM_SETPTAB_ENTRY (newpt, pt);
 179     if (SCM_BUF0 & (SCM_CAR (newpt) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))))
 180       scm_setbuf0 (newpt);
 181     SCM_SETSTREAM (newpt, (SCM)f);
 182     SCM_PTAB_ENTRY (newpt)->file_name = SCM_PTAB_ENTRY (oldpt)->file_name;
 183   }
 184   SCM_ALLOW_INTS;
 185   return newpt;
 186 }
 187
 188
 189
 190 SCM_PROC (s_sys_redirect_port, "redirect-port", 2, 0, 0, scm_sys_redirect_port);
 191 #ifdef __STDC__
 192 SCM
 193 scm_sys_redirect_port (SCM into_pt, SCM from_pt)
 194 #else
 195 SCM
 196 scm_sys_redirect_port (into_pt, from_pt)
 197      SCM into_pt;
 198      SCM from_pt;
 199 #endif
 200 {
 201   int ans, oldfd, newfd;
 202   SCM_DEFER_INTS;
 203   SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port);
 204   SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port);
 205   oldfd = fileno ((FILE *)SCM_STREAM (into_pt));
 206   if (oldfd == -1)
 207     SCM_SYSERROR (s_sys_redirect_port);
 208   newfd = fileno ((FILE *)SCM_STREAM (from_pt));
 209   if (newfd == -1)
 210     SCM_SYSERROR (s_sys_redirect_port);
 211   SCM_SYSCALL (ans = dup2 (oldfd, newfd));
 212   if (ans == -1)
 213     SCM_SYSERROR (s_sys_redirect_port);
 214   SCM_ALLOW_INTS;
 215   return SCM_UNSPECIFIED;
 216 }
 217
 218 SCM_PROC (s_sys_fileno, "fileno", 1, 0, 0, scm_sys_fileno);
 219 #ifdef __STDC__
 220 SCM
 221 scm_sys_fileno (SCM port)
 222 #else
 223 SCM
 224 scm_sys_fileno (port)
 225      SCM port;
 226 #endif
 227 {
 228   int fd;
 229   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno);
 230   fd = fileno ((FILE *)SCM_STREAM (port));
 231   if (fd == -1)
 232     SCM_SYSERROR (s_sys_fileno);
 233   return SCM_MAKINUM (fd);
 234 }
 235
 236 SCM_PROC (s_sys_isatty, "isatty?", 1, 0, 0, scm_sys_isatty_p);
 237 #ifdef __STDC__
 238 SCM
 239 scm_sys_isatty_p (SCM port)
 240 #else
 241 SCM
 242 scm_sys_isatty_p (port)
 243      SCM port;
 244 #endif
 245 {
 246   int rv;
 247   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty);
 248   rv = fileno ((FILE *)SCM_STREAM (port));
 249   if (rv == -1)
 250     SCM_SYSERROR (s_sys_isatty);
 251   rv = isatty (rv);
 252   return  rv ? SCM_BOOL_T : SCM_BOOL_F;
 253 }
 254
 255
 256
 257 SCM_PROC (s_sys_fdopen, "fdopen", 2, 0, 0, scm_sys_fdopen);
 258 #ifdef __STDC__
 259 SCM
 260 scm_sys_fdopen (SCM fdes, SCM modes)
 261 #else
 262 SCM
 263 scm_sys_fdopen (fdes, modes)
 264      SCM fdes;
 265      SCM modes;
 266 #endif
 267 {
 268   FILE *f;
 269   SCM port;
 270   struct scm_port_table * pt;
 271
 272   SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_sys_fdopen);
 273   SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_fdopen);
 274   SCM_NEWCELL (port);
 275   SCM_DEFER_INTS;
 276   f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes));
 277   if (f == NULL)
 278     SCM_SYSERROR (s_sys_fdopen);
 279   pt = scm_add_to_port_table (port);
 280   SCM_SETPTAB_ENTRY (port, pt);
 281   if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport
 282                   | scm_mode_bits (SCM_CHARS (modes))))
 283     scm_setbuf0 (port);
 284   SCM_SETSTREAM (port, (SCM)f);
 285   SCM_ALLOW_INTS;
 286   return port;
 287 }
 288
 289
 290
 291 /* Move a port's underlying file descriptor to a given value.
 292  * Returns  #f if fdes is already the given value.
 293  *          #t if fdes moved.
 294  * MOVE->FDES is implemented in Scheme and calls this primitive.
 295  */
 296 SCM_PROC (s_sys_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes);
 297 #ifdef __STDC__
 298 SCM
 299 scm_sys_primitive_move_to_fdes (SCM port, SCM fd)
 300 #else
 301 SCM
 302 scm_sys_primitive_move_to_fdes (port, fd)
 303      SCM port;
 304      SCM fd;
 305 #endif
 306 {
 307   FILE *stream;
 308   int old_fd;
 309   int new_fd;
 310   int rv;
 311
 312   SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_primitive_move_to_fdes);
 313   SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_sys_primitive_move_to_fdes);
 314   SCM_DEFER_INTS;
 315   stream = (FILE *)SCM_STREAM (port);
 316   old_fd = fileno (stream);
 317   new_fd = SCM_INUM (fd);
 318   if  (old_fd == new_fd)
 319     {
 320       SCM_ALLOW_INTS;
 321       return SCM_BOOL_F;
 322     }
 323   scm_evict_ports (new_fd);
 324   rv = dup2 (old_fd, new_fd);
 325   if (rv == -1)
 326     SCM_SYSERROR (s_sys_primitive_move_to_fdes);
 327   scm_setfileno (stream, new_fd);
 328   SCM_SYSCALL (close (old_fd));
 329   SCM_ALLOW_INTS;
 330   return SCM_BOOL_T;
 331 }
 332
 333 #ifdef __STDC__
 334 void
 335 scm_setfileno (FILE *fs, int fd)
 336 #else
 337 void
 338 scm_setfileno (fs, fd)
 339      FILE *fs;
 340      int fd;
 341 #endif
 342 {
 343 #ifdef SET_FILE_FD_FIELD
 344   SET_FILE_FD_FIELD(fs, fd);
 345 #else
 346   Configure could not guess the name of the correct field in a FILE *.
 347
 348   This function needs to be ported to your system.
 349
 350   SET_FILE_FD_FIELD should change the descriptor refered to by a stdio
 351   stream, and nothing else.
 352
 353   The way to port this file is to add cases to configure.in.  Search
 354   that file for "SET_FILE_FD_FIELD" and follow the examples there.
 355 #endif
 356 }
 357
 358 /* Move ports with the specified file descriptor to new descriptors,
 359  * reseting the revealed count to 0.
 360  * Should be called with SCM_DEFER_INTS active.
 361  */
 362 #ifdef __STDC__
 363 void
 364 scm_evict_ports (int fd)
 365 #else
 366 void
 367 scm_evict_ports (fd)
 368      int fd;
 369 #endif
 370 {
 371   int i;
 372
 373   for (i = 0; i < scm_port_table_size; i++)
 374     {
 375       if (SCM_FPORTP (scm_port_table[i]->port)
 376           && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd)
 377         {
 378           scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd));
 379           scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0));
 380         }
 381     }
 382 }
 383
 384 /* Return a list of ports using a given file descriptor.  */
 385 SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports);
 386 #ifdef __STDC__
 387 SCM
 388 scm_fdes_to_ports (SCM fd)
 389 #else
 390 SCM
 391 scm_fdes_to_ports (fd)
 392      SCM fd;
 393 #endif
 394 {
 395   SCM result = SCM_EOL;
 396   int int_fd;
 397   int i;
 398
 399   SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports);
 400   int_fd = SCM_INUM (fd);
 401
 402   SCM_DEFER_INTS;
 403   for (i = 0; i < scm_port_table_size; i++)
 404     {
 405       if (SCM_FPORTP (scm_port_table[i]->port)
 406           && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == int_fd)
 407         result = scm_cons (scm_port_table[i]->port, result);
 408     }
 409   SCM_ALLOW_INTS;
 410   return result;
 411 }
 412
 413 #ifdef __STDC__
 414 void
 415 scm_init_ioext (void)
 416 #else
 417 void
 418 scm_init_ioext ()
 419 #endif
 420 {
 421   /* fseek() symbols.  */
 422   scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET));
 423   scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR));
 424   scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END));
 425
 426   /* access() symbols.  */
 427   scm_sysintern ("R_OK", SCM_MAKINUM (R_OK));
 428   scm_sysintern ("W_OK", SCM_MAKINUM (W_OK));
 429   scm_sysintern ("X_OK", SCM_MAKINUM (X_OK));
 430   scm_sysintern ("F_OK", SCM_MAKINUM (F_OK));
 431
 432   /* File type/permission bits.  */
 433 #ifdef S_IRUSR
 434   scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR));
 435 #endif
 436 #ifdef S_IWUSR
 437   scm_sysintern ("S_IWUSR", SCM_MAKINUM (S_IWUSR));
 438 #endif
 439 #ifdef S_IXUSR
 440   scm_sysintern ("S_IXUSR", SCM_MAKINUM (S_IXUSR));
 441 #endif
 442 #ifdef S_IRWXU
 443   scm_sysintern ("S_IRWXU", SCM_MAKINUM (S_IRWXU));
 444 #endif
 445
 446 #ifdef S_IRGRP
 447   scm_sysintern ("S_IRGRP", SCM_MAKINUM (S_IRGRP));
 448 #endif
 449 #ifdef S_IWGRP
 450   scm_sysintern ("S_IWGRP", SCM_MAKINUM (S_IWGRP));
 451 #endif
 452 #ifdef S_IXGRP
 453   scm_sysintern ("S_IXGRP", SCM_MAKINUM (S_IXGRP));
 454 #endif
 455 #ifdef S_IRWXG
 456   scm_sysintern ("S_IRWXG", SCM_MAKINUM (S_IRWXG));
 457 #endif
 458
 459 #ifdef S_IROTH
 460   scm_sysintern ("S_IROTH", SCM_MAKINUM (S_IROTH));
 461 #endif
 462 #ifdef S_IWOTH
 463   scm_sysintern ("S_IWOTH", SCM_MAKINUM (S_IWOTH));
 464 #endif
 465 #ifdef S_IXOTH
 466   scm_sysintern ("S_IXOTH", SCM_MAKINUM (S_IXOTH));
 467 #endif
 468 #ifdef S_IRWXO
 469   scm_sysintern ("S_IRWXO", SCM_MAKINUM (S_IRWXO));
 470 #endif
 471
 472 #ifdef S_ISUID
 473   scm_sysintern ("S_ISUID", SCM_MAKINUM (S_ISUID));
 474 #endif
 475 #ifdef S_ISGID
 476   scm_sysintern ("S_ISGID", SCM_MAKINUM (S_ISGID));
 477 #endif
 478 #ifdef S_ISVTX
 479   scm_sysintern ("S_ISVTX", SCM_MAKINUM (S_ISVTX));
 480 #endif
 481
 482 #ifdef S_IFMT
 483   scm_sysintern ("S_IFMT", SCM_MAKINUM (S_IFMT));
 484 #endif
 485 #ifdef S_IFDIR
 486   scm_sysintern ("S_IFDIR", SCM_MAKINUM (S_IFDIR));
 487 #endif
 488 #ifdef S_IFCHR
 489   scm_sysintern ("S_IFCHR", SCM_MAKINUM (S_IFCHR));
 490 #endif
 491 #ifdef S_IFBLK
 492   scm_sysintern ("S_IFBLK", SCM_MAKINUM (S_IFBLK));
 493 #endif
 494 #ifdef S_IFREG
 495   scm_sysintern ("S_IFREG", SCM_MAKINUM (S_IFREG));
 496 #endif
 497 #ifdef S_IFLNK
 498   scm_sysintern ("S_IFLNK", SCM_MAKINUM (S_IFLNK));
 499 #endif
 500 #ifdef S_IFSOCK
 501   scm_sysintern ("S_IFSOCK", SCM_MAKINUM (S_IFSOCK));
 502 #endif
 503 #ifdef S_IFIFO
 504   scm_sysintern ("S_IFIFO", SCM_MAKINUM (S_IFIFO));
 505 #endif
 506 #include "ioext.x"
 507 }
 508