1 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006,
2 * 2011, 2014 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
31 #include "libguile/dynwind.h"
32 #include "libguile/feature.h"
33 #include "libguile/fports.h"
34 #include "libguile/hashtab.h"
35 #include "libguile/ioext.h"
36 #include "libguile/ports.h"
37 #include "libguile/strings.h"
38 #include "libguile/validate.h"
48 SCM_DEFINE (scm_ftell
, "ftell", 1, 0, 0,
50 "Return an integer representing the current position of\n"
51 "@var{fd_port}, measured from the beginning. Equivalent to:\n"
54 "(seek port 0 SEEK_CUR)\n"
56 #define FUNC_NAME s_scm_ftell
58 return scm_seek (fd_port
, SCM_INUM0
, scm_from_int (SEEK_CUR
));
62 SCM_DEFINE (scm_redirect_port
, "redirect-port", 2, 0, 0,
64 "This procedure takes two ports and duplicates the underlying file\n"
65 "descriptor from @var{old} into @var{new}. The\n"
66 "current file descriptor in @var{new} will be closed.\n"
67 "After the redirection the two ports will share a file position\n"
68 "and file status flags.\n\n"
69 "The return value is unspecified.\n\n"
70 "Unexpected behaviour can result if both ports are subsequently used\n"
71 "and the original and/or duplicate ports are buffered.\n\n"
72 "This procedure does not have any side effects on other ports or\n"
74 #define FUNC_NAME s_scm_redirect_port
76 int ans
, oldfd
, newfd
;
79 old
= SCM_COERCE_OUTPORT (old
);
80 new = SCM_COERCE_OUTPORT (new);
82 SCM_VALIDATE_OPFPORT (1, old
);
83 SCM_VALIDATE_OPFPORT (2, new);
84 oldfd
= SCM_FPORT_FDES (old
);
85 fp
= SCM_FSTREAM (new);
89 scm_t_port
*pt
= SCM_PTAB_ENTRY (new);
90 scm_t_port
*old_pt
= SCM_PTAB_ENTRY (old
);
91 scm_t_ptob_descriptor
*ptob
= SCM_PORT_DESCRIPTOR (new);
93 /* must flush to old fdes. */
94 if (pt
->rw_active
== SCM_PORT_WRITE
)
96 else if (pt
->rw_active
== SCM_PORT_READ
)
97 scm_end_input_unlocked (new);
98 ans
= dup2 (oldfd
, newfd
);
101 pt
->rw_random
= old_pt
->rw_random
;
102 /* continue using existing buffers, even if inappropriate. */
104 return SCM_UNSPECIFIED
;
108 SCM_DEFINE (scm_dup_to_fdes
, "dup->fdes", 1, 1, 0,
109 (SCM fd_or_port
, SCM fd
),
110 "Return a new integer file descriptor referring to the open file\n"
111 "designated by @var{fd_or_port}, which must be either an open\n"
112 "file port or a file descriptor.")
113 #define FUNC_NAME s_scm_dup_to_fdes
115 int oldfd
, newfd
, rv
;
117 fd_or_port
= SCM_COERCE_OUTPORT (fd_or_port
);
119 if (scm_is_integer (fd_or_port
))
120 oldfd
= scm_to_int (fd_or_port
);
123 SCM_VALIDATE_OPFPORT (1, fd_or_port
);
124 oldfd
= SCM_FPORT_FDES (fd_or_port
);
132 fd
= scm_from_int (newfd
);
136 newfd
= scm_to_int (fd
);
139 scm_evict_ports (newfd
); /* see scsh manual. */
140 rv
= dup2 (oldfd
, newfd
);
150 SCM_DEFINE (scm_dup2
, "dup2", 2, 0, 0,
151 (SCM oldfd
, SCM newfd
),
152 "A simple wrapper for the @code{dup2} system call.\n"
153 "Copies the file descriptor @var{oldfd} to descriptor\n"
154 "number @var{newfd}, replacing the previous meaning\n"
155 "of @var{newfd}. Both @var{oldfd} and @var{newfd} must\n"
157 "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
158 "is made to move away ports which are using @var{newfd}.\n"
159 "The return value is unspecified.")
160 #define FUNC_NAME s_scm_dup2
166 c_oldfd
= scm_to_int (oldfd
);
167 c_newfd
= scm_to_int (newfd
);
168 rv
= dup2 (c_oldfd
, c_newfd
);
171 return SCM_UNSPECIFIED
;
175 SCM_DEFINE (scm_fileno
, "fileno", 1, 0, 0,
177 "Return the integer file descriptor underlying @var{port}. Does\n"
178 "not change its revealed count.")
179 #define FUNC_NAME s_scm_fileno
181 port
= SCM_COERCE_OUTPORT (port
);
182 SCM_VALIDATE_OPFPORT (1, port
);
183 return scm_from_int (SCM_FPORT_FDES (port
));
187 /* GJB:FIXME:: why does this not throw
188 an error if the arg is not a port?
189 This proc as is would be better names isattyport?
190 if it is not going to assume that the arg is a port
192 [cmm] I don't see any problem with the above. why should a type
193 predicate assume _anything_ about its argument?
195 SCM_DEFINE (scm_isatty_p
, "isatty?", 1, 0, 0,
197 "Return @code{#t} if @var{port} is using a serial non--file\n"
198 "device, otherwise @code{#f}.")
199 #define FUNC_NAME s_scm_isatty_p
203 port
= SCM_COERCE_OUTPORT (port
);
205 if (!SCM_OPFPORTP (port
))
208 rv
= isatty (SCM_FPORT_FDES (port
));
209 return scm_from_bool(rv
);
215 SCM_DEFINE (scm_fdopen
, "fdopen", 2, 0, 0,
216 (SCM fdes
, SCM modes
),
217 "Return a new port based on the file descriptor @var{fdes}.\n"
218 "Modes are given by the string @var{modes}. The revealed count\n"
219 "of the port is initialized to zero. The modes string is the\n"
220 "same as that accepted by @ref{File Ports, open-file}.")
221 #define FUNC_NAME s_scm_fdopen
223 return scm_i_fdes_to_port (scm_to_int (fdes
),
224 scm_i_mode_bits (modes
), SCM_BOOL_F
);
230 /* Move a port's underlying file descriptor to a given value.
231 * Returns #f if fdes is already the given value.
233 * MOVE->FDES is implemented in Scheme and calls this primitive.
235 SCM_DEFINE (scm_primitive_move_to_fdes
, "primitive-move->fdes", 2, 0, 0,
237 "Moves the underlying file descriptor for @var{port} to the integer\n"
238 "value @var{fd} without changing the revealed count of @var{port}.\n"
239 "Any other ports already using this descriptor will be automatically\n"
240 "shifted to new descriptors and their revealed counts reset to zero.\n"
241 "The return value is @code{#f} if the file descriptor already had the\n"
242 "required value or @code{#t} if it was moved.")
243 #define FUNC_NAME s_scm_primitive_move_to_fdes
250 port
= SCM_COERCE_OUTPORT (port
);
252 SCM_VALIDATE_OPFPORT (1, port
);
253 stream
= SCM_FSTREAM (port
);
254 old_fd
= stream
->fdes
;
255 new_fd
= scm_to_int (fd
);
256 if (old_fd
== new_fd
)
260 scm_evict_ports (new_fd
);
261 rv
= dup2 (old_fd
, new_fd
);
264 stream
->fdes
= new_fd
;
265 SCM_SYSCALL (close (old_fd
));
271 get_matching_port (void *closure
, SCM port
, SCM result
)
273 int fd
= * (int *) closure
;
274 scm_t_port
*entry
= SCM_PTAB_ENTRY (port
);
276 if (SCM_OPFPORTP (port
)
277 && ((scm_t_fport
*) entry
->stream
)->fdes
== fd
)
278 result
= scm_cons (port
, result
);
283 /* Return a list of ports using a given file descriptor. */
284 SCM_DEFINE (scm_fdes_to_ports
, "fdes->ports", 1, 0, 0,
286 "Return a list of existing ports which have @var{fd} as an\n"
287 "underlying file descriptor, without changing their revealed\n"
289 #define FUNC_NAME s_scm_fdes_to_ports
291 SCM result
= SCM_EOL
;
292 int int_fd
= scm_to_int (fd
);
294 result
= scm_c_weak_set_fold (get_matching_port
,
295 (void*) &int_fd
, result
,
296 scm_i_port_weak_set
);
305 scm_add_feature ("i/o-extensions");
307 #include "libguile/ioext.x"