This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #78494] Pipes cause threads to hang on join()
[perl5.git] / perlio.c
CommitLineData
14a5cf38 1/*
5cb43542
RGS
2 * perlio.c
3 * Copyright (c) 1996-2006, Nick Ing-Simmons
1129b882 4 * Copyright (c) 2006, 2007, 2008 Larry Wall and others
5cb43542
RGS
5 *
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
760ac839
LW
8 */
9
14a5cf38 10/*
d31a8517
AT
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
4ac71550
TC
13 *
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
d31a8517
AT
15 */
16
166f8a29
DM
17/* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
21 */
22
d31a8517 23/*
71200d45 24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
14a5cf38 25 * at the dispatch tables, even when we do not need it for other reasons.
71200d45 26 * Invent a dSYS macro to abstract this out
14a5cf38 27 */
7bcba3d4
NIS
28#ifdef PERL_IMPLICIT_SYS
29#define dSYS dTHX
30#else
31#define dSYS dNOOP
32#endif
33
760ac839 34#define VOIDUSED 1
12ae5dfc
JH
35#ifdef PERL_MICRO
36# include "uconfig.h"
37#else
b0f06652
VK
38# ifndef USE_CROSS_COMPILE
39# include "config.h"
40# else
41# include "xconfig.h"
42# endif
12ae5dfc 43#endif
760ac839 44
6f9d8c32 45#define PERLIO_NOT_STDIO 0
760ac839 46#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
14a5cf38 47/*
71200d45 48 * #define PerlIO FILE
14a5cf38 49 */
760ac839
LW
50#endif
51/*
6f9d8c32 52 * This file provides those parts of PerlIO abstraction
88b61e10 53 * which are not #defined in perlio.h.
6f9d8c32 54 * Which these are depends on various Configure #ifdef's
760ac839
LW
55 */
56
57#include "EXTERN.h"
864dbfa3 58#define PERL_IN_PERLIO_C
760ac839
LW
59#include "perl.h"
60
32af7c23
CL
61#ifdef PERL_IMPLICIT_CONTEXT
62#undef dSYS
63#define dSYS dTHX
64#endif
65
0c4f7ff0
NIS
66#include "XSUB.h"
67
9cffb111
OS
68#ifdef __Lynx__
69/* Missing proto on LynxOS */
70int mkstemp(char*);
71#endif
72
abf9167d
DM
73#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
74
1b7a0411 75/* Call the callback or PerlIOBase, and return failure. */
b32dd47e 76#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
1b7a0411 77 if (PerlIOValid(f)) { \
46c461b5 78 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
79 if (tab && tab->callback) \
80 return (*tab->callback) args; \
81 else \
82 return PerlIOBase_ ## base args; \
83 } \
84 else \
85 SETERRNO(EBADF, SS_IVCHAN); \
86 return failure
87
88/* Call the callback or fail, and return failure. */
b32dd47e 89#define Perl_PerlIO_or_fail(f, callback, failure, args) \
1b7a0411 90 if (PerlIOValid(f)) { \
46c461b5 91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
92 if (tab && tab->callback) \
93 return (*tab->callback) args; \
94 SETERRNO(EINVAL, LIB_INVARG); \
95 } \
96 else \
97 SETERRNO(EBADF, SS_IVCHAN); \
98 return failure
99
100/* Call the callback or PerlIOBase, and be void. */
b32dd47e 101#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
1b7a0411 102 if (PerlIOValid(f)) { \
46c461b5 103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
106 else \
107 PerlIOBase_ ## base args; \
1b7a0411
JH
108 } \
109 else \
110 SETERRNO(EBADF, SS_IVCHAN)
111
112/* Call the callback or fail, and be void. */
b32dd47e 113#define Perl_PerlIO_or_fail_void(f, callback, args) \
1b7a0411 114 if (PerlIOValid(f)) { \
46c461b5 115 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
116 if (tab && tab->callback) \
117 (*tab->callback) args; \
37725cdc
NIS
118 else \
119 SETERRNO(EINVAL, LIB_INVARG); \
1b7a0411
JH
120 } \
121 else \
122 SETERRNO(EBADF, SS_IVCHAN)
123
89a3a251
JH
124#if defined(__osf__) && _XOPEN_SOURCE < 500
125extern int fseeko(FILE *, off_t, int);
126extern off_t ftello(FILE *);
127#endif
128
71ab4674 129#ifndef USE_SFIO
a0c21aa1
JH
130
131EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
132
71ab4674
SP
133int
134perlsio_binmode(FILE *fp, int iotype, int mode)
135{
136 /*
137 * This used to be contents of do_binmode in doio.c
138 */
139#ifdef DOSISH
cd86ed9d 140# if defined(atarist)
58c0efa5 141 PERL_UNUSED_ARG(iotype);
71ab4674
SP
142 if (!fflush(fp)) {
143 if (mode & O_BINARY)
144 ((FILE *) fp)->_flag |= _IOBIN;
145 else
146 ((FILE *) fp)->_flag &= ~_IOBIN;
147 return 1;
148 }
149 return 0;
150# else
151 dTHX;
58c0efa5 152 PERL_UNUSED_ARG(iotype);
71ab4674
SP
153#ifdef NETWARE
154 if (PerlLIO_setmode(fp, mode) != -1) {
155#else
156 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
157#endif
158# if defined(WIN32) && defined(__BORLANDC__)
159 /*
160 * The translation mode of the stream is maintained independent
161of
162 * the translation mode of the fd in the Borland RTL (heavy
163 * digging through their runtime sources reveal). User has to
164set
165 * the mode explicitly for the stream (though they don't
166document
167 * this anywhere). GSAR 97-5-24
168 */
169 fseek(fp, 0L, 0);
170 if (mode & O_BINARY)
171 fp->flags |= _F_BIN;
172 else
173 fp->flags &= ~_F_BIN;
174# endif
175 return 1;
176 }
177 else
178 return 0;
179# endif
180#else
181# if defined(USEMYBINMODE)
182 dTHX;
58c0efa5
RGS
183# if defined(__CYGWIN__)
184 PERL_UNUSED_ARG(iotype);
185# endif
71ab4674
SP
186 if (my_binmode(fp, iotype, mode) != FALSE)
187 return 1;
188 else
189 return 0;
190# else
191 PERL_UNUSED_ARG(fp);
192 PERL_UNUSED_ARG(iotype);
193 PERL_UNUSED_ARG(mode);
194 return 1;
195# endif
196#endif
197}
198#endif /* sfio */
199
06c7082d 200#ifndef O_ACCMODE
22569500 201#define O_ACCMODE 3 /* Assume traditional implementation */
06c7082d
NIS
202#endif
203
204int
205PerlIO_intmode2str(int rawmode, char *mode, int *writing)
206{
de009b76 207 const int result = rawmode & O_ACCMODE;
06c7082d
NIS
208 int ix = 0;
209 int ptype;
210 switch (result) {
211 case O_RDONLY:
212 ptype = IoTYPE_RDONLY;
213 break;
214 case O_WRONLY:
215 ptype = IoTYPE_WRONLY;
216 break;
217 case O_RDWR:
218 default:
219 ptype = IoTYPE_RDWR;
220 break;
221 }
222 if (writing)
223 *writing = (result != O_RDONLY);
224
225 if (result == O_RDONLY) {
226 mode[ix++] = 'r';
227 }
228#ifdef O_APPEND
229 else if (rawmode & O_APPEND) {
230 mode[ix++] = 'a';
231 if (result != O_WRONLY)
232 mode[ix++] = '+';
233 }
234#endif
235 else {
236 if (result == O_WRONLY)
237 mode[ix++] = 'w';
238 else {
239 mode[ix++] = 'r';
240 mode[ix++] = '+';
241 }
242 }
243 if (rawmode & O_BINARY)
244 mode[ix++] = 'b';
245 mode[ix] = '\0';
246 return ptype;
247}
248
eb73beca
NIS
249#ifndef PERLIO_LAYERS
250int
251PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
252{
6874a2de
NIS
253 if (!names || !*names
254 || strEQ(names, ":crlf")
255 || strEQ(names, ":raw")
256 || strEQ(names, ":bytes")
257 ) {
14a5cf38
JH
258 return 0;
259 }
260 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
261 /*
71200d45 262 * NOTREACHED
14a5cf38
JH
263 */
264 return -1;
eb73beca
NIS
265}
266
13621cfb
NIS
267void
268PerlIO_destruct(pTHX)
269{
270}
271
f5b9d040
NIS
272int
273PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
274{
92bff44d 275#ifdef USE_SFIO
8772537c
AL
276 PERL_UNUSED_ARG(iotype);
277 PERL_UNUSED_ARG(mode);
278 PERL_UNUSED_ARG(names);
14a5cf38 279 return 1;
92bff44d 280#else
14a5cf38 281 return perlsio_binmode(fp, iotype, mode);
92bff44d 282#endif
f5b9d040 283}
60382766 284
e0fa5af2 285PerlIO *
ecdeb87c 286PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
e0fa5af2 287{
a0fd4948 288#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
0553478e
NIS
289 return NULL;
290#else
291#ifdef PERL_IMPLICIT_SYS
22569500 292 return PerlSIO_fdupopen(f);
0553478e 293#else
30753f56
NIS
294#ifdef WIN32
295 return win32_fdupopen(f);
296#else
e0fa5af2 297 if (f) {
504618e9 298 const int fd = PerlLIO_dup(PerlIO_fileno(f));
e0fa5af2 299 if (fd >= 0) {
06c7082d 300 char mode[8];
a5936e02 301#ifdef DJGPP
dcda55fc
AL
302 const int omode = djgpp_get_stream_mode(f);
303#else
304 const int omode = fcntl(fd, F_GETFL);
a5936e02 305#endif
06c7082d 306 PerlIO_intmode2str(omode,mode,NULL);
e0fa5af2 307 /* the r+ is a hack */
06c7082d 308 return PerlIO_fdopen(fd, mode);
e0fa5af2
NIS
309 }
310 return NULL;
311 }
312 else {
93189314 313 SETERRNO(EBADF, SS_IVCHAN);
e0fa5af2 314 }
7114a2d2 315#endif
e0fa5af2 316 return NULL;
0553478e 317#endif
30753f56 318#endif
e0fa5af2
NIS
319}
320
321
14a5cf38 322/*
71200d45 323 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
14a5cf38 324 */
ee518936
NIS
325
326PerlIO *
14a5cf38
JH
327PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
328 int imode, int perm, PerlIO *old, int narg, SV **args)
329{
7cf31beb
NIS
330 if (narg) {
331 if (narg > 1) {
3b8752bb 332 Perl_croak(aTHX_ "More than one argument to open");
7cf31beb 333 }
14a5cf38
JH
334 if (*args == &PL_sv_undef)
335 return PerlIO_tmpfile();
336 else {
e62f0680 337 const char *name = SvPV_nolen_const(*args);
3b6c1aba 338 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
339 fd = PerlLIO_open3(name, imode, perm);
340 if (fd >= 0)
de009b76 341 return PerlIO_fdopen(fd, mode + 1);
14a5cf38
JH
342 }
343 else if (old) {
344 return PerlIO_reopen(name, mode, old);
345 }
346 else {
347 return PerlIO_open(name, mode);
348 }
349 }
350 }
351 else {
352 return PerlIO_fdopen(fd, (char *) mode);
353 }
354 return NULL;
ee518936
NIS
355}
356
0c4f7ff0
NIS
357XS(XS_PerlIO__Layer__find)
358{
14a5cf38
JH
359 dXSARGS;
360 if (items < 2)
361 Perl_croak(aTHX_ "Usage class->find(name[,load])");
362 else {
dcda55fc 363 const char * const name = SvPV_nolen_const(ST(1));
14a5cf38
JH
364 ST(0) = (strEQ(name, "crlf")
365 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
366 XSRETURN(1);
367 }
0c4f7ff0
NIS
368}
369
370
371void
372Perl_boot_core_PerlIO(pTHX)
373{
14a5cf38 374 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
0c4f7ff0
NIS
375}
376
ac27b0f5
NIS
377#endif
378
32e30700 379
6f9d8c32 380#ifdef PERLIO_IS_STDIO
760ac839
LW
381
382void
e8632036 383PerlIO_init(pTHX)
760ac839 384{
96a5add6 385 PERL_UNUSED_CONTEXT;
14a5cf38
JH
386 /*
387 * Does nothing (yet) except force this file to be included in perl
71200d45 388 * binary. That allows this file to force inclusion of other functions
14a5cf38 389 * that may be required by loadable extensions e.g. for
71200d45 390 * FileHandle::tmpfile
14a5cf38 391 */
760ac839
LW
392}
393
33dcbb9a
PP
394#undef PerlIO_tmpfile
395PerlIO *
8ac85365 396PerlIO_tmpfile(void)
33dcbb9a 397{
14a5cf38 398 return tmpfile();
33dcbb9a
PP
399}
400
22569500 401#else /* PERLIO_IS_STDIO */
760ac839
LW
402
403#ifdef USE_SFIO
404
405#undef HAS_FSETPOS
406#undef HAS_FGETPOS
407
14a5cf38
JH
408/*
409 * This section is just to make sure these functions get pulled in from
71200d45 410 * libsfio.a
14a5cf38 411 */
760ac839
LW
412
413#undef PerlIO_tmpfile
414PerlIO *
c78749f2 415PerlIO_tmpfile(void)
760ac839 416{
14a5cf38 417 return sftmp(0);
760ac839
LW
418}
419
420void
e8632036 421PerlIO_init(pTHX)
760ac839 422{
96a5add6 423 PERL_UNUSED_CONTEXT;
14a5cf38
JH
424 /*
425 * Force this file to be included in perl binary. Which allows this
426 * file to force inclusion of other functions that may be required by
71200d45 427 * loadable extensions e.g. for FileHandle::tmpfile
14a5cf38 428 */
760ac839 429
14a5cf38 430 /*
71200d45 431 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
14a5cf38 432 * results in a lot of lseek()s to regular files and lot of small
71200d45 433 * writes to pipes.
14a5cf38
JH
434 */
435 sfset(sfstdout, SF_SHARE, 0);
760ac839
LW
436}
437
b9d6bf13 438/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
92bff44d 439PerlIO *
4b069b44 440PerlIO_importFILE(FILE *stdio, const char *mode)
92bff44d 441{
de009b76 442 const int fd = fileno(stdio);
4b069b44 443 if (!mode || !*mode) {
81428673 444 mode = "r+";
4b069b44
NIS
445 }
446 return PerlIO_fdopen(fd, mode);
92bff44d
NIS
447}
448
449FILE *
450PerlIO_findFILE(PerlIO *pio)
451{
de009b76
AL
452 const int fd = PerlIO_fileno(pio);
453 FILE * const f = fdopen(fd, "r+");
14a5cf38
JH
454 PerlIO_flush(pio);
455 if (!f && errno == EINVAL)
456 f = fdopen(fd, "w");
457 if (!f && errno == EINVAL)
458 f = fdopen(fd, "r");
459 return f;
92bff44d
NIS
460}
461
462
22569500 463#else /* USE_SFIO */
6f9d8c32 464/*======================================================================================*/
14a5cf38 465/*
71200d45 466 * Implement all the PerlIO interface ourselves.
9e353e3b 467 */
760ac839 468
76ced9ad
NIS
469#include "perliol.h"
470
14a5cf38
JH
471/*
472 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
71200d45 473 * files
14a5cf38 474 */
02f66e2f
NIS
475#ifdef I_UNISTD
476#include <unistd.h>
477#endif
06da4f11
NIS
478#ifdef HAS_MMAP
479#include <sys/mman.h>
480#endif
481
6f9d8c32 482void
14a5cf38
JH
483PerlIO_debug(const char *fmt, ...)
484{
14a5cf38
JH
485 va_list ap;
486 dSYS;
487 va_start(ap, fmt);
582588d2
NC
488 if (!PL_perlio_debug_fd) {
489 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
490 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
491 if (s && *s)
492 PL_perlio_debug_fd
493 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
494 else
495 PL_perlio_debug_fd = -1;
496 } else {
497 /* tainting or set*id, so ignore the environment, and ensure we
498 skip these tests next time through. */
27da23d5 499 PL_perlio_debug_fd = -1;
582588d2 500 }
14a5cf38 501 }
27da23d5 502 if (PL_perlio_debug_fd > 0) {
14a5cf38 503 dTHX;
70ace5da 504#ifdef USE_ITHREADS
dcda55fc 505 const char * const s = CopFILE(PL_curcop);
70ace5da
NIS
506 /* Use fixed buffer as sv_catpvf etc. needs SVs */
507 char buffer[1024];
1208b3dd
JH
508 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
509 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
510 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
70ace5da 511#else
dcda55fc
AL
512 const char *s = CopFILE(PL_curcop);
513 STRLEN len;
550e2ce0
NC
514 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
515 (IV) CopLINE(PL_curcop));
14a5cf38
JH
516 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
517
b83604b4 518 s = SvPV_const(sv, len);
27da23d5 519 PerlLIO_write(PL_perlio_debug_fd, s, len);
14a5cf38 520 SvREFCNT_dec(sv);
70ace5da 521#endif
14a5cf38
JH
522 }
523 va_end(ap);
6f9d8c32
NIS
524}
525
9e353e3b
NIS
526/*--------------------------------------------------------------------------------------*/
527
14a5cf38 528/*
71200d45 529 * Inner level routines
14a5cf38 530 */
9e353e3b 531
16865ff7
DM
532/* check that the head field of each layer points back to the head */
533
534#ifdef DEBUGGING
535# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
536static void
537PerlIO_verify_head(pTHX_ PerlIO *f)
538{
539 PerlIOl *head, *p;
540 int seen = 0;
541 if (!PerlIOValid(f))
542 return;
543 p = head = PerlIOBase(f)->head;
544 assert(p);
545 do {
546 assert(p->head == head);
547 if (p == (PerlIOl*)f)
548 seen = 1;
549 p = p->next;
550 } while (p);
551 assert(seen);
552}
553#else
554# define VERIFY_HEAD(f)
555#endif
556
557
14a5cf38 558/*
71200d45 559 * Table of pointers to the PerlIO structs (malloc'ed)
14a5cf38 560 */
05d1247b 561#define PERLIO_TABLE_SIZE 64
6f9d8c32 562
8995e67d
DM
563static void
564PerlIO_init_table(pTHX)
565{
566 if (PL_perlio)
567 return;
568 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
569}
570
571
572
760ac839 573PerlIO *
5f1a76d0 574PerlIO_allocate(pTHX)
6f9d8c32 575{
97aff369 576 dVAR;
14a5cf38 577 /*
71200d45 578 * Find a free slot in the table, allocating new table as necessary
14a5cf38 579 */
303f2dc3
DM
580 PerlIOl **last;
581 PerlIOl *f;
a1ea730d 582 last = &PL_perlio;
14a5cf38
JH
583 while ((f = *last)) {
584 int i;
303f2dc3 585 last = (PerlIOl **) (f);
14a5cf38 586 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 587 if (!((++f)->next)) {
abf9167d 588 f->flags = 0; /* lockcnt */
303f2dc3 589 f->tab = NULL;
16865ff7 590 f->head = f;
303f2dc3 591 return (PerlIO *)f;
14a5cf38
JH
592 }
593 }
594 }
303f2dc3 595 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
14a5cf38
JH
596 if (!f) {
597 return NULL;
598 }
303f2dc3 599 *last = (PerlIOl*) f++;
abf9167d 600 f->flags = 0; /* lockcnt */
303f2dc3 601 f->tab = NULL;
16865ff7 602 f->head = f;
303f2dc3 603 return (PerlIO*) f;
05d1247b
NIS
604}
605
a1ea730d
NIS
606#undef PerlIO_fdupopen
607PerlIO *
ecdeb87c 608PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
a1ea730d 609{
04892f78 610 if (PerlIOValid(f)) {
de009b76 611 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
fe5a182c 612 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
210e727c
JH
613 if (tab && tab->Dup)
614 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
37725cdc
NIS
615 else {
616 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
617 }
a1ea730d 618 }
210e727c
JH
619 else
620 SETERRNO(EBADF, SS_IVCHAN);
621
622 return NULL;
a1ea730d
NIS
623}
624
625void
303f2dc3 626PerlIO_cleantable(pTHX_ PerlIOl **tablep)
05d1247b 627{
303f2dc3 628 PerlIOl * const table = *tablep;
14a5cf38
JH
629 if (table) {
630 int i;
303f2dc3 631 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
14a5cf38 632 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
303f2dc3
DM
633 PerlIOl * const f = table + i;
634 if (f->next) {
635 PerlIO_close(&(f->next));
14a5cf38
JH
636 }
637 }
3a1ee7e8 638 Safefree(table);
14a5cf38 639 *tablep = NULL;
05d1247b 640 }
05d1247b
NIS
641}
642
fcf2db38
NIS
643
644PerlIO_list_t *
3a1ee7e8 645PerlIO_list_alloc(pTHX)
fcf2db38 646{
14a5cf38 647 PerlIO_list_t *list;
96a5add6 648 PERL_UNUSED_CONTEXT;
a02a5408 649 Newxz(list, 1, PerlIO_list_t);
14a5cf38
JH
650 list->refcnt = 1;
651 return list;
fcf2db38
NIS
652}
653
654void
3a1ee7e8 655PerlIO_list_free(pTHX_ PerlIO_list_t *list)
fcf2db38 656{
14a5cf38
JH
657 if (list) {
658 if (--list->refcnt == 0) {
659 if (list->array) {
14a5cf38 660 IV i;
ef8d46e8
VP
661 for (i = 0; i < list->cur; i++)
662 SvREFCNT_dec(list->array[i].arg);
14a5cf38
JH
663 Safefree(list->array);
664 }
665 Safefree(list);
666 }
667 }
fcf2db38
NIS
668}
669
670void
3a1ee7e8 671PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
14a5cf38 672{
97aff369 673 dVAR;
334e202e 674 PerlIO_pair_t *p;
b37c2d43
AL
675 PERL_UNUSED_CONTEXT;
676
14a5cf38
JH
677 if (list->cur >= list->len) {
678 list->len += 8;
679 if (list->array)
680 Renew(list->array, list->len, PerlIO_pair_t);
681 else
a02a5408 682 Newx(list->array, list->len, PerlIO_pair_t);
14a5cf38
JH
683 }
684 p = &(list->array[list->cur++]);
685 p->funcs = funcs;
686 if ((p->arg = arg)) {
f84c484e 687 SvREFCNT_inc_simple_void_NN(arg);
14a5cf38 688 }
fcf2db38
NIS
689}
690
3a1ee7e8
NIS
691PerlIO_list_t *
692PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
693{
b37c2d43 694 PerlIO_list_t *list = NULL;
694c95cf
JH
695 if (proto) {
696 int i;
697 list = PerlIO_list_alloc(aTHX);
698 for (i=0; i < proto->cur; i++) {
a951d81d
BL
699 SV *arg = proto->array[i].arg;
700#ifdef sv_dup
701 if (arg && param)
702 arg = sv_dup(arg, param);
703#else
704 PERL_UNUSED_ARG(param);
705#endif
694c95cf
JH
706 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
707 }
3a1ee7e8
NIS
708 }
709 return list;
710}
4a4a6116 711
05d1247b 712void
3a1ee7e8 713PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
9a6404c5 714{
3aaf42a7 715#ifdef USE_ITHREADS
303f2dc3
DM
716 PerlIOl **table = &proto->Iperlio;
717 PerlIOl *f;
3a1ee7e8
NIS
718 PL_perlio = NULL;
719 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
720 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
8995e67d 721 PerlIO_init_table(aTHX);
a25429c6 722 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
3a1ee7e8
NIS
723 while ((f = *table)) {
724 int i;
303f2dc3 725 table = (PerlIOl **) (f++);
3a1ee7e8 726 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM
727 if (f->next) {
728 (void) fp_dup(&(f->next), 0, param);
3a1ee7e8
NIS
729 }
730 f++;
731 }
732 }
1b6737cc 733#else
a25429c6 734 PERL_UNUSED_CONTEXT;
1b6737cc
AL
735 PERL_UNUSED_ARG(proto);
736 PERL_UNUSED_ARG(param);
3aaf42a7 737#endif
9a6404c5
DM
738}
739
740void
13621cfb
NIS
741PerlIO_destruct(pTHX)
742{
97aff369 743 dVAR;
303f2dc3
DM
744 PerlIOl **table = &PL_perlio;
745 PerlIOl *f;
694c95cf 746#ifdef USE_ITHREADS
a25429c6 747 PerlIO_debug("Destruct %p\n",(void*)aTHX);
694c95cf 748#endif
14a5cf38
JH
749 while ((f = *table)) {
750 int i;
303f2dc3 751 table = (PerlIOl **) (f++);
14a5cf38 752 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 753 PerlIO *x = &(f->next);
dcda55fc 754 const PerlIOl *l;
14a5cf38 755 while ((l = *x)) {
cc6623a8 756 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
14a5cf38
JH
757 PerlIO_debug("Destruct popping %s\n", l->tab->name);
758 PerlIO_flush(x);
759 PerlIO_pop(aTHX_ x);
760 }
761 else {
762 x = PerlIONext(x);
763 }
764 }
765 f++;
766 }
767 }
13621cfb
NIS
768}
769
770void
a999f61b 771PerlIO_pop(pTHX_ PerlIO *f)
760ac839 772{
dcda55fc 773 const PerlIOl *l = *f;
16865ff7 774 VERIFY_HEAD(f);
14a5cf38 775 if (l) {
cc6623a8
DM
776 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
777 l->tab ? l->tab->name : "(Null)");
778 if (l->tab && l->tab->Popped) {
14a5cf38
JH
779 /*
780 * If popped returns non-zero do not free its layer structure
781 * it has either done so itself, or it is shared and still in
71200d45 782 * use
14a5cf38 783 */
f62ce20a 784 if ((*l->tab->Popped) (aTHX_ f) != 0)
14a5cf38
JH
785 return;
786 }
abf9167d
DM
787 if (PerlIO_lockcnt(f)) {
788 /* we're in use; defer freeing the structure */
789 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
790 PerlIOBase(f)->tab = NULL;
791 }
792 else {
793 *f = l->next;
794 Safefree(l);
795 }
796
a8c08ecd 797 }
6f9d8c32
NIS
798}
799
39f7a870
JH
800/* Return as an array the stack of layers on a filehandle. Note that
801 * the stack is returned top-first in the array, and there are three
802 * times as many array elements as there are layers in the stack: the
803 * first element of a layer triplet is the name, the second one is the
804 * arguments, and the third one is the flags. */
805
806AV *
807PerlIO_get_layers(pTHX_ PerlIO *f)
808{
97aff369 809 dVAR;
dcda55fc 810 AV * const av = newAV();
39f7a870 811
dcda55fc
AL
812 if (PerlIOValid(f)) {
813 PerlIOl *l = PerlIOBase(f);
814
815 while (l) {
92e45a3e
NC
816 /* There is some collusion in the implementation of
817 XS_PerlIO_get_layers - it knows that name and flags are
818 generated as fresh SVs here, and takes advantage of that to
819 "copy" them by taking a reference. If it changes here, it needs
820 to change there too. */
dcda55fc
AL
821 SV * const name = l->tab && l->tab->name ?
822 newSVpv(l->tab->name, 0) : &PL_sv_undef;
823 SV * const arg = l->tab && l->tab->Getarg ?
824 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
825 av_push(av, name);
826 av_push(av, arg);
827 av_push(av, newSViv((IV)l->flags));
828 l = l->next;
829 }
830 }
39f7a870 831
dcda55fc 832 return av;
39f7a870
JH
833}
834
9e353e3b 835/*--------------------------------------------------------------------------------------*/
14a5cf38 836/*
71200d45 837 * XS Interface for perl code
14a5cf38 838 */
9e353e3b 839
fcf2db38 840PerlIO_funcs *
2edd7e44 841PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
f3862f8b 842{
27da23d5 843 dVAR;
14a5cf38
JH
844 IV i;
845 if ((SSize_t) len <= 0)
846 len = strlen(name);
3a1ee7e8 847 for (i = 0; i < PL_known_layers->cur; i++) {
46c461b5 848 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
a9f76400 849 if (memEQ(f->name, name, len) && f->name[len] == 0) {
fe5a182c 850 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
14a5cf38
JH
851 return f;
852 }
853 }
3a1ee7e8
NIS
854 if (load && PL_subname && PL_def_layerlist
855 && PL_def_layerlist->cur >= 2) {
d7a09b41
SR
856 if (PL_in_load_module) {
857 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
858 return NULL;
859 } else {
396482e1 860 SV * const pkgsv = newSVpvs("PerlIO");
46c461b5 861 SV * const layer = newSVpvn(name, len);
b96d8cd9 862 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
46c461b5 863 ENTER;
4fa7c2bf 864 SAVEBOOL(PL_in_load_module);
c9bca74a 865 if (cv) {
9cfa90c0 866 SAVEGENERICSV(PL_warnhook);
ad64d0ec 867 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
c9bca74a 868 }
4fa7c2bf 869 PL_in_load_module = TRUE;
d7a09b41
SR
870 /*
871 * The two SVs are magically freed by load_module
872 */
a0714e2c 873 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
d7a09b41
SR
874 LEAVE;
875 return PerlIO_find_layer(aTHX_ name, len, 0);
876 }
14a5cf38
JH
877 }
878 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
879 return NULL;
f3862f8b
NIS
880}
881
2a1bc955 882#ifdef USE_ATTRIBUTES_FOR_PERLIO
b13b2135
NIS
883
884static int
885perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
886{
14a5cf38 887 if (SvROK(sv)) {
159b6efe 888 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
dcda55fc
AL
889 PerlIO * const ifp = IoIFP(io);
890 PerlIO * const ofp = IoOFP(io);
be2597df
MHM
891 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
892 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
14a5cf38
JH
893 }
894 return 0;
b13b2135
NIS
895}
896
897static int
898perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
899{
14a5cf38 900 if (SvROK(sv)) {
159b6efe 901 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
dcda55fc
AL
902 PerlIO * const ifp = IoIFP(io);
903 PerlIO * const ofp = IoOFP(io);
be2597df
MHM
904 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
905 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
14a5cf38
JH
906 }
907 return 0;
b13b2135
NIS
908}
909
910static int
911perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
912{
be2597df 913 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
14a5cf38 914 return 0;
b13b2135
NIS
915}
916
917static int
918perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
919{
be2597df 920 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
14a5cf38 921 return 0;
b13b2135
NIS
922}
923
924MGVTBL perlio_vtab = {
14a5cf38
JH
925 perlio_mg_get,
926 perlio_mg_set,
22569500 927 NULL, /* len */
14a5cf38
JH
928 perlio_mg_clear,
929 perlio_mg_free
b13b2135
NIS
930};
931
932XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
933{
14a5cf38 934 dXSARGS;
dcda55fc
AL
935 SV * const sv = SvRV(ST(1));
936 AV * const av = newAV();
14a5cf38
JH
937 MAGIC *mg;
938 int count = 0;
939 int i;
ad64d0ec 940 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
14a5cf38
JH
941 SvRMAGICAL_off(sv);
942 mg = mg_find(sv, PERL_MAGIC_ext);
943 mg->mg_virtual = &perlio_vtab;
944 mg_magical(sv);
be2597df 945 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
14a5cf38
JH
946 for (i = 2; i < items; i++) {
947 STRLEN len;
dcda55fc
AL
948 const char * const name = SvPV_const(ST(i), len);
949 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
14a5cf38 950 if (layer) {
b37c2d43 951 av_push(av, SvREFCNT_inc_simple_NN(layer));
14a5cf38
JH
952 }
953 else {
954 ST(count) = ST(i);
955 count++;
956 }
957 }
958 SvREFCNT_dec(av);
959 XSRETURN(count);
960}
961
22569500 962#endif /* USE_ATTIBUTES_FOR_PERLIO */
2a1bc955 963
e3f3bf95
NIS
964SV *
965PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
f3862f8b 966{
da51bb9b 967 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
46c461b5 968 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
14a5cf38 969 return sv;
e3f3bf95
NIS
970}
971
5ca1d77f 972XS(XS_PerlIO__Layer__NoWarnings)
c9bca74a 973{
486ec47a 974 /* This is used as a %SIG{__WARN__} handler to suppress warnings
c9bca74a
NIS
975 during loading of layers.
976 */
97aff369 977 dVAR;
c9bca74a 978 dXSARGS;
58c0efa5 979 PERL_UNUSED_ARG(cv);
c9bca74a 980 if (items)
e62f0680 981 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
c9bca74a
NIS
982 XSRETURN(0);
983}
984
5ca1d77f 985XS(XS_PerlIO__Layer__find)
0c4f7ff0 986{
97aff369 987 dVAR;
14a5cf38 988 dXSARGS;
58c0efa5 989 PERL_UNUSED_ARG(cv);
14a5cf38
JH
990 if (items < 2)
991 Perl_croak(aTHX_ "Usage class->find(name[,load])");
992 else {
de009b76 993 STRLEN len;
46c461b5 994 const char * const name = SvPV_const(ST(1), len);
de009b76 995 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
46c461b5 996 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
14a5cf38
JH
997 ST(0) =
998 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
999 &PL_sv_undef;
1000 XSRETURN(1);
1001 }
0c4f7ff0
NIS
1002}
1003
e3f3bf95
NIS
1004void
1005PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
1006{
97aff369 1007 dVAR;
3a1ee7e8
NIS
1008 if (!PL_known_layers)
1009 PL_known_layers = PerlIO_list_alloc(aTHX);
a0714e2c 1010 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
fe5a182c 1011 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
f3862f8b
NIS
1012}
1013
1141d9f8 1014int
fcf2db38 1015PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1141d9f8 1016{
97aff369 1017 dVAR;
14a5cf38
JH
1018 if (names) {
1019 const char *s = names;
1020 while (*s) {
1021 while (isSPACE(*s) || *s == ':')
1022 s++;
1023 if (*s) {
1024 STRLEN llen = 0;
1025 const char *e = s;
bd61b366 1026 const char *as = NULL;
14a5cf38
JH
1027 STRLEN alen = 0;
1028 if (!isIDFIRST(*s)) {
1029 /*
1030 * Message is consistent with how attribute lists are
1031 * passed. Even though this means "foo : : bar" is
71200d45 1032 * seen as an invalid separator character.
14a5cf38 1033 */
de009b76 1034 const char q = ((*s == '\'') ? '"' : '\'');
a2a5de95
NC
1035 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1036 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1037 q, *s, q, s);
93189314 1038 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
1039 return -1;
1040 }
1041 do {
1042 e++;
1043 } while (isALNUM(*e));
1044 llen = e - s;
1045 if (*e == '(') {
1046 int nesting = 1;
1047 as = ++e;
1048 while (nesting) {
1049 switch (*e++) {
1050 case ')':
1051 if (--nesting == 0)
1052 alen = (e - 1) - as;
1053 break;
1054 case '(':
1055 ++nesting;
1056 break;
1057 case '\\':
1058 /*
1059 * It's a nul terminated string, not allowed
1060 * to \ the terminating null. Anything other
71200d45 1061 * character is passed over.
14a5cf38
JH
1062 */
1063 if (*e++) {
1064 break;
1065 }
1066 /*
71200d45 1067 * Drop through
14a5cf38
JH
1068 */
1069 case '\0':
1070 e--;
a2a5de95
NC
1071 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1072 "Argument list not closed for PerlIO layer \"%.*s\"",
1073 (int) (e - s), s);
14a5cf38
JH
1074 return -1;
1075 default:
1076 /*
71200d45 1077 * boring.
14a5cf38
JH
1078 */
1079 break;
1080 }
1081 }
1082 }
1083 if (e > s) {
46c461b5 1084 PerlIO_funcs * const layer =
14a5cf38
JH
1085 PerlIO_find_layer(aTHX_ s, llen, 1);
1086 if (layer) {
a951d81d
BL
1087 SV *arg = NULL;
1088 if (as)
1089 arg = newSVpvn(as, alen);
3a1ee7e8 1090 PerlIO_list_push(aTHX_ av, layer,
a951d81d 1091 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1092 SvREFCNT_dec(arg);
14a5cf38
JH
1093 }
1094 else {
a2a5de95
NC
1095 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1096 (int) llen, s);
14a5cf38
JH
1097 return -1;
1098 }
1099 }
1100 s = e;
1101 }
1102 }
1103 }
1104 return 0;
1141d9f8
NIS
1105}
1106
dfebf958 1107void
fcf2db38 1108PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
dfebf958 1109{
97aff369 1110 dVAR;
27da23d5 1111 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
35990314 1112#ifdef PERLIO_USING_CRLF
6ce75a77 1113 tab = &PerlIO_crlf;
846be114 1114#else
6ce75a77 1115 if (PerlIO_stdio.Set_ptrcnt)
22569500 1116 tab = &PerlIO_stdio;
846be114 1117#endif
14a5cf38 1118 PerlIO_debug("Pushing %s\n", tab->name);
3a1ee7e8 1119 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
14a5cf38 1120 &PL_sv_undef);
dfebf958
NIS
1121}
1122
e3f3bf95 1123SV *
14a5cf38 1124PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
e3f3bf95 1125{
14a5cf38 1126 return av->array[n].arg;
e3f3bf95
NIS
1127}
1128
f3862f8b 1129PerlIO_funcs *
14a5cf38 1130PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
f3862f8b 1131{
14a5cf38
JH
1132 if (n >= 0 && n < av->cur) {
1133 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1134 av->array[n].funcs->name);
1135 return av->array[n].funcs;
1136 }
1137 if (!def)
1138 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1139 return def;
e3f3bf95
NIS
1140}
1141
4ec2216f
NIS
1142IV
1143PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1144{
8772537c
AL
1145 PERL_UNUSED_ARG(mode);
1146 PERL_UNUSED_ARG(arg);
1147 PERL_UNUSED_ARG(tab);
4ec2216f
NIS
1148 if (PerlIOValid(f)) {
1149 PerlIO_flush(f);
1150 PerlIO_pop(aTHX_ f);
1151 return 0;
1152 }
1153 return -1;
1154}
1155
27da23d5 1156PERLIO_FUNCS_DECL(PerlIO_remove) = {
4ec2216f
NIS
1157 sizeof(PerlIO_funcs),
1158 "pop",
1159 0,
1160 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1161 PerlIOPop_pushed,
1162 NULL,
c0888ace 1163 PerlIOBase_open,
4ec2216f
NIS
1164 NULL,
1165 NULL,
1166 NULL,
1167 NULL,
1168 NULL,
1169 NULL,
1170 NULL,
1171 NULL,
de009b76
AL
1172 NULL,
1173 NULL,
4ec2216f
NIS
1174 NULL, /* flush */
1175 NULL, /* fill */
1176 NULL,
1177 NULL,
1178 NULL,
1179 NULL,
1180 NULL, /* get_base */
1181 NULL, /* get_bufsiz */
1182 NULL, /* get_ptr */
1183 NULL, /* get_cnt */
1184 NULL, /* set_ptrcnt */
1185};
1186
fcf2db38 1187PerlIO_list_t *
e3f3bf95
NIS
1188PerlIO_default_layers(pTHX)
1189{
97aff369 1190 dVAR;
3a1ee7e8 1191 if (!PL_def_layerlist) {
bd61b366 1192 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
27da23d5 1193 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
3a1ee7e8 1194 PL_def_layerlist = PerlIO_list_alloc(aTHX);
27da23d5 1195 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
979e2c82 1196#if defined(WIN32)
27da23d5 1197 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
2f8118af 1198#if 0
14a5cf38 1199 osLayer = &PerlIO_win32;
0c4128ad 1200#endif
2f8118af 1201#endif
27da23d5
JH
1202 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1203 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1204 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1205 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
06da4f11 1206#ifdef HAS_MMAP
27da23d5 1207 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
06da4f11 1208#endif
27da23d5
JH
1209 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1210 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1211 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
3a1ee7e8 1212 PerlIO_list_push(aTHX_ PL_def_layerlist,
14a5cf38
JH
1213 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1214 &PL_sv_undef);
1215 if (s) {
3a1ee7e8 1216 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
14a5cf38
JH
1217 }
1218 else {
3a1ee7e8 1219 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
14a5cf38 1220 }
1141d9f8 1221 }
3a1ee7e8
NIS
1222 if (PL_def_layerlist->cur < 2) {
1223 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
f3862f8b 1224 }
3a1ee7e8 1225 return PL_def_layerlist;
e3f3bf95
NIS
1226}
1227
0c4f7ff0
NIS
1228void
1229Perl_boot_core_PerlIO(pTHX)
1230{
1231#ifdef USE_ATTRIBUTES_FOR_PERLIO
14a5cf38
JH
1232 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1233 __FILE__);
0c4f7ff0 1234#endif
14a5cf38 1235 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
c9bca74a 1236 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
0c4f7ff0 1237}
e3f3bf95
NIS
1238
1239PerlIO_funcs *
1240PerlIO_default_layer(pTHX_ I32 n)
1241{
97aff369 1242 dVAR;
46c461b5 1243 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
14a5cf38
JH
1244 if (n < 0)
1245 n += av->cur;
27da23d5 1246 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
f3862f8b
NIS
1247}
1248
a999f61b
NIS
1249#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1250#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
60382766
NIS
1251
1252void
1141d9f8 1253PerlIO_stdstreams(pTHX)
60382766 1254{
97aff369 1255 dVAR;
a1ea730d 1256 if (!PL_perlio) {
8995e67d 1257 PerlIO_init_table(aTHX);
14a5cf38
JH
1258 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1259 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1260 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1261 }
60382766
NIS
1262}
1263
1264PerlIO *
27da23d5 1265PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
14a5cf38 1266{
16865ff7 1267 VERIFY_HEAD(f);
2dc2558e 1268 if (tab->fsize != sizeof(PerlIO_funcs)) {
0dc17498 1269 Perl_croak( aTHX_
5cf96513
RB
1270 "%s (%"UVuf") does not match %s (%"UVuf")",
1271 "PerlIO layer function table size", (UV)tab->fsize,
1272 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
2dc2558e
NIS
1273 }
1274 if (tab->size) {
b464bac0 1275 PerlIOl *l;
2dc2558e 1276 if (tab->size < sizeof(PerlIOl)) {
0dc17498 1277 Perl_croak( aTHX_
5cf96513
RB
1278 "%s (%"UVuf") smaller than %s (%"UVuf")",
1279 "PerlIO layer instance size", (UV)tab->size,
1280 "size expected by this perl", (UV)sizeof(PerlIOl) );
2dc2558e
NIS
1281 }
1282 /* Real layer with a data area */
002e75cf
JH
1283 if (f) {
1284 char *temp;
1285 Newxz(temp, tab->size, char);
1286 l = (PerlIOl*)temp;
1287 if (l) {
1288 l->next = *f;
1289 l->tab = (PerlIO_funcs*) tab;
16865ff7 1290 l->head = ((PerlIOl*)f)->head;
002e75cf
JH
1291 *f = l;
1292 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1293 (void*)f, tab->name,
1294 (mode) ? mode : "(Null)", (void*)arg);
1295 if (*l->tab->Pushed &&
1296 (*l->tab->Pushed)
1297 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1298 PerlIO_pop(aTHX_ f);
1299 return NULL;
1300 }
2dc2558e 1301 }
002e75cf
JH
1302 else
1303 return NULL;
2dc2558e
NIS
1304 }
1305 }
1306 else if (f) {
1307 /* Pseudo-layer where push does its own stack adjust */
00f51856
NIS
1308 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1309 (mode) ? mode : "(Null)", (void*)arg);
210e727c 1310 if (tab->Pushed &&
27da23d5 1311 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
210e727c 1312 return NULL;
14a5cf38
JH
1313 }
1314 }
1315 return f;
60382766
NIS
1316}
1317
81fe74fb
LT
1318PerlIO *
1319PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1320 IV n, const char *mode, int fd, int imode, int perm,
1321 PerlIO *old, int narg, SV **args)
1322{
1323 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1324 if (tab && tab->Open) {
1325 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
6d5bdea2 1326 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
81fe74fb
LT
1327 PerlIO_close(ret);
1328 return NULL;
1329 }
1330 return ret;
1331 }
1332 SETERRNO(EINVAL, LIB_INVARG);
1333 return NULL;
1334}
1335
dfebf958 1336IV
86e05cf2
NIS
1337PerlIOBase_binmode(pTHX_ PerlIO *f)
1338{
1339 if (PerlIOValid(f)) {
1340 /* Is layer suitable for raw stream ? */
cc6623a8 1341 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
86e05cf2
NIS
1342 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1343 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1344 }
1345 else {
1346 /* Not suitable - pop it */
1347 PerlIO_pop(aTHX_ f);
1348 }
1349 return 0;
1350 }
1351 return -1;
1352}
1353
1354IV
2dc2558e 1355PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
dfebf958 1356{
8772537c
AL
1357 PERL_UNUSED_ARG(mode);
1358 PERL_UNUSED_ARG(arg);
1359 PERL_UNUSED_ARG(tab);
86e05cf2 1360
04892f78 1361 if (PerlIOValid(f)) {
86e05cf2 1362 PerlIO *t;
de009b76 1363 const PerlIOl *l;
14a5cf38 1364 PerlIO_flush(f);
86e05cf2
NIS
1365 /*
1366 * Strip all layers that are not suitable for a raw stream
1367 */
1368 t = f;
1369 while (t && (l = *t)) {
cc6623a8 1370 if (l->tab && l->tab->Binmode) {
86e05cf2 1371 /* Has a handler - normal case */
9d97e8b8 1372 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
86e05cf2
NIS
1373 if (*t == l) {
1374 /* Layer still there - move down a layer */
1375 t = PerlIONext(t);
1376 }
1377 }
1378 else {
1379 return -1;
1380 }
14a5cf38
JH
1381 }
1382 else {
86e05cf2
NIS
1383 /* No handler - pop it */
1384 PerlIO_pop(aTHX_ t);
14a5cf38
JH
1385 }
1386 }
86e05cf2 1387 if (PerlIOValid(f)) {
cc6623a8
DM
1388 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1389 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
86e05cf2
NIS
1390 return 0;
1391 }
14a5cf38
JH
1392 }
1393 return -1;
dfebf958
NIS
1394}
1395
ac27b0f5 1396int
14a5cf38 1397PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
d9dac8cd 1398 PerlIO_list_t *layers, IV n, IV max)
14a5cf38 1399{
14a5cf38
JH
1400 int code = 0;
1401 while (n < max) {
8772537c 1402 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
14a5cf38
JH
1403 if (tab) {
1404 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1405 code = -1;
1406 break;
1407 }
1408 }
1409 n++;
1410 }
1411 return code;
e3f3bf95
NIS
1412}
1413
1414int
ac27b0f5
NIS
1415PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1416{
14a5cf38 1417 int code = 0;
da0fccaa
DG
1418 ENTER;
1419 save_scalar(PL_errgv);
53f1b6d2 1420 if (f && names) {
8772537c 1421 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
14a5cf38
JH
1422 code = PerlIO_parse_layers(aTHX_ layers, names);
1423 if (code == 0) {
d9dac8cd 1424 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
14a5cf38 1425 }
3a1ee7e8 1426 PerlIO_list_free(aTHX_ layers);
ac27b0f5 1427 }
da0fccaa 1428 LEAVE;
14a5cf38 1429 return code;
ac27b0f5
NIS
1430}
1431
f3862f8b 1432
60382766 1433/*--------------------------------------------------------------------------------------*/
14a5cf38 1434/*
71200d45 1435 * Given the abstraction above the public API functions
14a5cf38 1436 */
60382766
NIS
1437
1438int
f5b9d040 1439PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 1440{
68b5363f 1441 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
cc6623a8
DM
1442 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1443 PerlIOBase(f)->tab->name : "(Null)",
68b5363f
PD
1444 iotype, mode, (names) ? names : "(Null)");
1445
03c0554d
NIS
1446 if (names) {
1447 /* Do not flush etc. if (e.g.) switching encodings.
1448 if a pushed layer knows it needs to flush lower layers
1449 (for example :unix which is never going to call them)
1450 it can do the flush when it is pushed.
1451 */
1452 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1453 }
1454 else {
86e05cf2 1455 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
35990314 1456#ifdef PERLIO_USING_CRLF
03c0554d
NIS
1457 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1458 O_BINARY so we can look for it in mode.
1459 */
1460 if (!(mode & O_BINARY)) {
1461 /* Text mode */
86e05cf2
NIS
1462 /* FIXME?: Looking down the layer stack seems wrong,
1463 but is a way of reaching past (say) an encoding layer
1464 to flip CRLF-ness of the layer(s) below
1465 */
03c0554d
NIS
1466 while (*f) {
1467 /* Perhaps we should turn on bottom-most aware layer
1468 e.g. Ilya's idea that UNIX TTY could serve
1469 */
cc6623a8
DM
1470 if (PerlIOBase(f)->tab &&
1471 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1472 {
03c0554d
NIS
1473 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1474 /* Not in text mode - flush any pending stuff and flip it */
1475 PerlIO_flush(f);
1476 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1477 }
1478 /* Only need to turn it on in one layer so we are done */
1479 return TRUE;
ed53a2bb 1480 }
03c0554d 1481 f = PerlIONext(f);
14a5cf38 1482 }
03c0554d
NIS
1483 /* Not finding a CRLF aware layer presumably means we are binary
1484 which is not what was requested - so we failed
1485 We _could_ push :crlf layer but so could caller
1486 */
1487 return FALSE;
14a5cf38 1488 }
6ce75a77 1489#endif
86e05cf2
NIS
1490 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1491 So code that used to be here is now in PerlIORaw_pushed().
03c0554d 1492 */
a0714e2c 1493 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
14a5cf38 1494 }
f5b9d040
NIS
1495}
1496
f5b9d040 1497int
e87a358a 1498PerlIO__close(pTHX_ PerlIO *f)
f5b9d040 1499{
37725cdc 1500 if (PerlIOValid(f)) {
46c461b5 1501 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
37725cdc
NIS
1502 if (tab && tab->Close)
1503 return (*tab->Close)(aTHX_ f);
1504 else
1505 return PerlIOBase_close(aTHX_ f);
1506 }
14a5cf38 1507 else {
93189314 1508 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1509 return -1;
1510 }
76ced9ad
NIS
1511}
1512
b931b1d9 1513int
e87a358a 1514Perl_PerlIO_close(pTHX_ PerlIO *f)
b931b1d9 1515{
de009b76 1516 const int code = PerlIO__close(aTHX_ f);
37725cdc
NIS
1517 while (PerlIOValid(f)) {
1518 PerlIO_pop(aTHX_ f);
abf9167d
DM
1519 if (PerlIO_lockcnt(f))
1520 /* we're in use; the 'pop' deferred freeing the structure */
1521 f = PerlIONext(f);
f6c77cf1 1522 }
14a5cf38 1523 return code;
b931b1d9
NIS
1524}
1525
b931b1d9 1526int
e87a358a 1527Perl_PerlIO_fileno(pTHX_ PerlIO *f)
b931b1d9 1528{
97aff369 1529 dVAR;
b32dd47e 1530 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
b931b1d9
NIS
1531}
1532
1141d9f8 1533
fcf2db38 1534static PerlIO_funcs *
2edd7e44
NIS
1535PerlIO_layer_from_ref(pTHX_ SV *sv)
1536{
97aff369 1537 dVAR;
14a5cf38 1538 /*
71200d45 1539 * For any scalar type load the handler which is bundled with perl
14a5cf38 1540 */
526fd1b4 1541 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
75208dda
RGS
1542 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1543 /* This isn't supposed to happen, since PerlIO::scalar is core,
1544 * but could happen anyway in smaller installs or with PAR */
a2a5de95
NC
1545 if (!f)
1546 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
75208dda
RGS
1547 return f;
1548 }
14a5cf38
JH
1549
1550 /*
71200d45 1551 * For other types allow if layer is known but don't try and load it
14a5cf38
JH
1552 */
1553 switch (SvTYPE(sv)) {
1554 case SVt_PVAV:
6a245ed1 1555 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
14a5cf38 1556 case SVt_PVHV:
6a245ed1 1557 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
14a5cf38 1558 case SVt_PVCV:
6a245ed1 1559 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
14a5cf38 1560 case SVt_PVGV:
6a245ed1 1561 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
42d0e0b7
AL
1562 default:
1563 return NULL;
14a5cf38 1564 }
2edd7e44
NIS
1565}
1566
fcf2db38 1567PerlIO_list_t *
14a5cf38
JH
1568PerlIO_resolve_layers(pTHX_ const char *layers,
1569 const char *mode, int narg, SV **args)
1570{
97aff369 1571 dVAR;
14a5cf38
JH
1572 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1573 int incdef = 1;
a1ea730d 1574 if (!PL_perlio)
14a5cf38
JH
1575 PerlIO_stdstreams(aTHX);
1576 if (narg) {
dcda55fc 1577 SV * const arg = *args;
14a5cf38 1578 /*
71200d45
NIS
1579 * If it is a reference but not an object see if we have a handler
1580 * for it
14a5cf38
JH
1581 */
1582 if (SvROK(arg) && !sv_isobject(arg)) {
46c461b5 1583 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1584 if (handler) {
3a1ee7e8
NIS
1585 def = PerlIO_list_alloc(aTHX);
1586 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH
1587 incdef = 0;
1588 }
1589 /*
e934609f 1590 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1591 * something sensible else we will just stringfy and open
71200d45 1592 * resulting string.
14a5cf38
JH
1593 */
1594 }
1595 }
9fe371da 1596 if (!layers || !*layers)
11bcd5da 1597 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1598 if (layers && *layers) {
1599 PerlIO_list_t *av;
1600 if (incdef) {
a951d81d 1601 av = PerlIO_clone_list(aTHX_ def, NULL);
14a5cf38
JH
1602 }
1603 else {
1604 av = def;
1605 }
0cff2cf3
NIS
1606 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1607 return av;
1608 }
1609 else {
1610 PerlIO_list_free(aTHX_ av);
b37c2d43 1611 return NULL;
0cff2cf3 1612 }
14a5cf38
JH
1613 }
1614 else {
1615 if (incdef)
1616 def->refcnt++;
1617 return def;
1618 }
ee518936
NIS
1619}
1620
1621PerlIO *
14a5cf38
JH
1622PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1623 int imode, int perm, PerlIO *f, int narg, SV **args)
1624{
97aff369 1625 dVAR;
14a5cf38
JH
1626 if (!f && narg == 1 && *args == &PL_sv_undef) {
1627 if ((f = PerlIO_tmpfile())) {
9fe371da 1628 if (!layers || !*layers)
11bcd5da 1629 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1630 if (layers && *layers)
1631 PerlIO_apply_layers(aTHX_ f, mode, layers);
1632 }
1633 }
1634 else {
de009b76 1635 PerlIO_list_t *layera;
14a5cf38
JH
1636 IV n;
1637 PerlIO_funcs *tab = NULL;
04892f78 1638 if (PerlIOValid(f)) {
14a5cf38 1639 /*
71200d45
NIS
1640 * This is "reopen" - it is not tested as perl does not use it
1641 * yet
14a5cf38
JH
1642 */
1643 PerlIOl *l = *f;
3a1ee7e8 1644 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1645 while (l) {
a951d81d 1646 SV *arg = NULL;
cc6623a8 1647 if (l->tab && l->tab->Getarg)
a951d81d
BL
1648 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1649 PerlIO_list_push(aTHX_ layera, l->tab,
1650 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1651 SvREFCNT_dec(arg);
14a5cf38
JH
1652 l = *PerlIONext(&l);
1653 }
1654 }
1655 else {
1656 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS
1657 if (!layera) {
1658 return NULL;
1659 }
14a5cf38
JH
1660 }
1661 /*
71200d45 1662 * Start at "top" of layer stack
14a5cf38
JH
1663 */
1664 n = layera->cur - 1;
1665 while (n >= 0) {
46c461b5 1666 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH
1667 if (t && t->Open) {
1668 tab = t;
1669 break;
1670 }
1671 n--;
1672 }
1673 if (tab) {
1674 /*
71200d45 1675 * Found that layer 'n' can do opens - call it
14a5cf38 1676 */
7cf31beb 1677 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1678 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1679 }
14a5cf38 1680 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
355d3743
PD
1681 tab->name, layers ? layers : "(Null)", mode, fd,
1682 imode, perm, (void*)f, narg, (void*)args);
210e727c
JH
1683 if (tab->Open)
1684 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1685 f, narg, args);
1686 else {
1687 SETERRNO(EINVAL, LIB_INVARG);
1688 f = NULL;
1689 }
14a5cf38
JH
1690 if (f) {
1691 if (n + 1 < layera->cur) {
1692 /*
1693 * More layers above the one that we used to open -
71200d45 1694 * apply them now
14a5cf38 1695 */
d9dac8cd
NIS
1696 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1697 /* If pushing layers fails close the file */
1698 PerlIO_close(f);
14a5cf38
JH
1699 f = NULL;
1700 }
1701 }
1702 }
1703 }
3a1ee7e8 1704 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH
1705 }
1706 return f;
ee518936 1707}
b931b1d9
NIS
1708
1709
9e353e3b 1710SSize_t
e87a358a 1711Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1712{
7918f24d
NC
1713 PERL_ARGS_ASSERT_PERLIO_READ;
1714
b32dd47e 1715 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1716}
1717
313ca112 1718SSize_t
e87a358a 1719Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1720{
7918f24d
NC
1721 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1722
b32dd47e 1723 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1724}
1725
9e353e3b 1726SSize_t
e87a358a 1727Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1728{
7918f24d
NC
1729 PERL_ARGS_ASSERT_PERLIO_WRITE;
1730
b32dd47e 1731 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1732}
1733
6f9d8c32 1734int
e87a358a 1735Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1736{
b32dd47e 1737 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW
1738}
1739
9e353e3b 1740Off_t
e87a358a 1741Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1742{
b32dd47e 1743 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW
1744}
1745
6f9d8c32 1746int
e87a358a 1747Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1748{
97aff369 1749 dVAR;
14a5cf38
JH
1750 if (f) {
1751 if (*f) {
de009b76 1752 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH
1753
1754 if (tab && tab->Flush)
f62ce20a 1755 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH
1756 else
1757 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH
1758 }
1759 else {
fe5a182c 1760 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
93189314 1761 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1762 return -1;
1763 }
1764 }
1765 else {
1766 /*
1767 * Is it good API design to do flush-all on NULL, a potentially
486ec47a 1768 * erroneous input? Maybe some magical value (PerlIO*
14a5cf38
JH
1769 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1770 * things on fflush(NULL), but should we be bound by their design
71200d45 1771 * decisions? --jhi
14a5cf38 1772 */
303f2dc3
DM
1773 PerlIOl **table = &PL_perlio;
1774 PerlIOl *ff;
14a5cf38 1775 int code = 0;
303f2dc3 1776 while ((ff = *table)) {
14a5cf38 1777 int i;
303f2dc3 1778 table = (PerlIOl **) (ff++);
14a5cf38 1779 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 1780 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
14a5cf38 1781 code = -1;
303f2dc3 1782 ff++;
14a5cf38
JH
1783 }
1784 }
1785 return code;
1786 }
760ac839
LW
1787}
1788
a9c883f6 1789void
f62ce20a 1790PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1791{
97aff369 1792 dVAR;
303f2dc3
DM
1793 PerlIOl **table = &PL_perlio;
1794 PerlIOl *f;
14a5cf38
JH
1795 while ((f = *table)) {
1796 int i;
303f2dc3 1797 table = (PerlIOl **) (f++);
14a5cf38 1798 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM
1799 if (f->next
1800 && (PerlIOBase(&(f->next))->
14a5cf38
JH
1801 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1802 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
303f2dc3 1803 PerlIO_flush(&(f->next));
14a5cf38
JH
1804 f++;
1805 }
a9c883f6 1806 }
a9c883f6
NIS
1807}
1808
06da4f11 1809int
e87a358a 1810Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1811{
b32dd47e 1812 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS
1813}
1814
f3862f8b
NIS
1815int
1816PerlIO_isutf8(PerlIO *f)
1817{
1b7a0411
JH
1818 if (PerlIOValid(f))
1819 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1820 else
1821 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1822
1b7a0411 1823 return -1;
f3862f8b
NIS
1824}
1825
6f9d8c32 1826int
e87a358a 1827Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1828{
b32dd47e 1829 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS
1830}
1831
9e353e3b 1832int
e87a358a 1833Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1834{
b32dd47e 1835 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS
1836}
1837
9e353e3b 1838void
e87a358a 1839Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1840{
b32dd47e 1841 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS
1842}
1843
9e353e3b 1844void
e87a358a 1845Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1846{
b32dd47e 1847 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS
1848}
1849
9e353e3b
NIS
1850int
1851PerlIO_has_base(PerlIO *f)
1852{
1b7a0411 1853 if (PerlIOValid(f)) {
46c461b5 1854 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1855
1856 if (tab)
1857 return (tab->Get_base != NULL);
1b7a0411 1858 }
1b7a0411
JH
1859
1860 return 0;
760ac839
LW
1861}
1862
9e353e3b
NIS
1863int
1864PerlIO_fast_gets(PerlIO *f)
760ac839 1865{
d7dfc388
SK
1866 if (PerlIOValid(f)) {
1867 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1868 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411 1869
d7dfc388
SK
1870 if (tab)
1871 return (tab->Set_ptrcnt != NULL);
d7dfc388 1872 }
14a5cf38 1873 }
1b7a0411 1874
14a5cf38 1875 return 0;
9e353e3b
NIS
1876}
1877
9e353e3b
NIS
1878int
1879PerlIO_has_cntptr(PerlIO *f)
1880{
04892f78 1881 if (PerlIOValid(f)) {
46c461b5 1882 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1883
1884 if (tab)
1885 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
14a5cf38 1886 }
1b7a0411 1887
14a5cf38 1888 return 0;
9e353e3b
NIS
1889}
1890
9e353e3b
NIS
1891int
1892PerlIO_canset_cnt(PerlIO *f)
1893{
04892f78 1894 if (PerlIOValid(f)) {
46c461b5 1895 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1896
1897 if (tab)
1898 return (tab->Set_ptrcnt != NULL);
14a5cf38 1899 }
1b7a0411 1900
14a5cf38 1901 return 0;
760ac839
LW
1902}
1903
888911fc 1904STDCHAR *
e87a358a 1905Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1906{
b32dd47e 1907 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS
1908}
1909
9e353e3b 1910int
e87a358a 1911Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1912{
b32dd47e 1913 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS
1914}
1915
9e353e3b 1916STDCHAR *
e87a358a 1917Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1918{
b32dd47e 1919 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS
1920}
1921
05d1247b 1922int
e87a358a 1923Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1924{
b32dd47e 1925 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS
1926}
1927
9e353e3b 1928void
e87a358a 1929Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
9e353e3b 1930{
b32dd47e 1931 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS
1932}
1933
9e353e3b 1934void
e87a358a 1935Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
9e353e3b 1936{
b32dd47e 1937 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS
1938}
1939
4ec2216f 1940
9e353e3b 1941/*--------------------------------------------------------------------------------------*/
14a5cf38 1942/*
71200d45 1943 * utf8 and raw dummy layers
14a5cf38 1944 */
dfebf958 1945
26fb694e 1946IV
2dc2558e 1947PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1948{
96a5add6 1949 PERL_UNUSED_CONTEXT;
8772537c
AL
1950 PERL_UNUSED_ARG(mode);
1951 PERL_UNUSED_ARG(arg);
00f51856 1952 if (PerlIOValid(f)) {
cc6623a8 1953 if (tab && tab->kind & PERLIO_K_UTF8)
14a5cf38
JH
1954 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1955 else
1956 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1957 return 0;
1958 }
1959 return -1;
26fb694e
NIS
1960}
1961
27da23d5 1962PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1963 sizeof(PerlIO_funcs),
14a5cf38 1964 "utf8",
2dc2558e 1965 0,
6874a2de 1966 PERLIO_K_DUMMY | PERLIO_K_UTF8,
14a5cf38
JH
1967 PerlIOUtf8_pushed,
1968 NULL,
c0888ace 1969 PerlIOBase_open,
14a5cf38
JH
1970 NULL,
1971 NULL,
1972 NULL,
1973 NULL,
1974 NULL,
1975 NULL,
1976 NULL,
1977 NULL,
de009b76
AL
1978 NULL,
1979 NULL,
22569500
NIS
1980 NULL, /* flush */
1981 NULL, /* fill */
14a5cf38
JH
1982 NULL,
1983 NULL,
1984 NULL,
1985 NULL,
22569500
NIS
1986 NULL, /* get_base */
1987 NULL, /* get_bufsiz */
1988 NULL, /* get_ptr */
1989 NULL, /* get_cnt */
1990 NULL, /* set_ptrcnt */
26fb694e
NIS
1991};
1992
27da23d5 1993PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1994 sizeof(PerlIO_funcs),
14a5cf38 1995 "bytes",
2dc2558e 1996 0,
14a5cf38
JH
1997 PERLIO_K_DUMMY,
1998 PerlIOUtf8_pushed,
1999 NULL,
c0888ace 2000 PerlIOBase_open,
14a5cf38
JH
2001 NULL,
2002 NULL,
2003 NULL,
2004 NULL,
2005 NULL,
2006 NULL,
2007 NULL,
2008 NULL,
de009b76
AL
2009 NULL,
2010 NULL,
22569500
NIS
2011 NULL, /* flush */
2012 NULL, /* fill */
14a5cf38
JH
2013 NULL,
2014 NULL,
2015 NULL,
2016 NULL,
22569500
NIS
2017 NULL, /* get_base */
2018 NULL, /* get_bufsiz */
2019 NULL, /* get_ptr */
2020 NULL, /* get_cnt */
2021 NULL, /* set_ptrcnt */
dfebf958
NIS
2022};
2023
27da23d5 2024PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 2025 sizeof(PerlIO_funcs),
14a5cf38 2026 "raw",
2dc2558e 2027 0,
14a5cf38
JH
2028 PERLIO_K_DUMMY,
2029 PerlIORaw_pushed,
2030 PerlIOBase_popped,
ecfd0649 2031 PerlIOBase_open,
14a5cf38
JH
2032 NULL,
2033 NULL,
2034 NULL,
2035 NULL,
2036 NULL,
2037 NULL,
2038 NULL,
2039 NULL,
de009b76
AL
2040 NULL,
2041 NULL,
22569500
NIS
2042 NULL, /* flush */
2043 NULL, /* fill */
14a5cf38
JH
2044 NULL,
2045 NULL,
2046 NULL,
2047 NULL,
22569500
NIS
2048 NULL, /* get_base */
2049 NULL, /* get_bufsiz */
2050 NULL, /* get_ptr */
2051 NULL, /* get_cnt */
2052 NULL, /* set_ptrcnt */
dfebf958
NIS
2053};
2054/*--------------------------------------------------------------------------------------*/
2055/*--------------------------------------------------------------------------------------*/
14a5cf38 2056/*
71200d45 2057 * "Methods" of the "base class"
14a5cf38 2058 */
9e353e3b
NIS
2059
2060IV
f62ce20a 2061PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 2062{
04892f78 2063 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS
2064}
2065
f5b9d040 2066char *
81428673 2067PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH
2068{
2069 char *s = buf;
81428673 2070 if (PerlIOValid(f)) {
de009b76 2071 const IV flags = PerlIOBase(f)->flags;
81428673
NIS
2072 if (flags & PERLIO_F_APPEND) {
2073 *s++ = 'a';
2074 if (flags & PERLIO_F_CANREAD) {
2075 *s++ = '+';
2076 }
14a5cf38 2077 }
81428673
NIS
2078 else if (flags & PERLIO_F_CANREAD) {
2079 *s++ = 'r';
2080 if (flags & PERLIO_F_CANWRITE)
2081 *s++ = '+';
2082 }
2083 else if (flags & PERLIO_F_CANWRITE) {
2084 *s++ = 'w';
2085 if (flags & PERLIO_F_CANREAD) {
2086 *s++ = '+';
2087 }
14a5cf38 2088 }
35990314 2089#ifdef PERLIO_USING_CRLF
81428673
NIS
2090 if (!(flags & PERLIO_F_CRLF))
2091 *s++ = 'b';
5f1a76d0 2092#endif
81428673 2093 }
14a5cf38
JH
2094 *s = '\0';
2095 return buf;
f5b9d040
NIS
2096}
2097
81428673 2098
76ced9ad 2099IV
2dc2558e 2100PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 2101{
de009b76 2102 PerlIOl * const l = PerlIOBase(f);
96a5add6 2103 PERL_UNUSED_CONTEXT;
8772537c 2104 PERL_UNUSED_ARG(arg);
de009b76 2105
14a5cf38
JH
2106 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2107 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
cc6623a8 2108 if (tab && tab->Set_ptrcnt != NULL)
14a5cf38
JH
2109 l->flags |= PERLIO_F_FASTGETS;
2110 if (mode) {
3b6c1aba 2111 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2112 mode++;
2113 switch (*mode++) {
2114 case 'r':
2115 l->flags |= PERLIO_F_CANREAD;
2116 break;
2117 case 'a':
2118 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2119 break;
2120 case 'w':
2121 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2122 break;
2123 default:
93189314 2124 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2125 return -1;
2126 }
2127 while (*mode) {
2128 switch (*mode++) {
2129 case '+':
2130 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2131 break;
2132 case 'b':
2133 l->flags &= ~PERLIO_F_CRLF;
2134 break;
2135 case 't':
2136 l->flags |= PERLIO_F_CRLF;
2137 break;
2138 default:
93189314 2139 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2140 return -1;
2141 }
2142 }
2143 }
2144 else {
2145 if (l->next) {
2146 l->flags |= l->next->flags &
2147 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2148 PERLIO_F_APPEND);
2149 }
2150 }
5e2ab84b 2151#if 0
14a5cf38 2152 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
6c9570dc 2153 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
14a5cf38 2154 l->flags, PerlIO_modestr(f, temp));
5e2ab84b 2155#endif
14a5cf38 2156 return 0;
76ced9ad
NIS
2157}
2158
2159IV
f62ce20a 2160PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2161{
96a5add6 2162 PERL_UNUSED_CONTEXT;
8772537c 2163 PERL_UNUSED_ARG(f);
14a5cf38 2164 return 0;
760ac839
LW
2165}
2166
9e353e3b 2167SSize_t
f62ce20a 2168PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2169{
14a5cf38 2170 /*
71200d45 2171 * Save the position as current head considers it
14a5cf38 2172 */
de009b76 2173 const Off_t old = PerlIO_tell(f);
a0714e2c 2174 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2175 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2176 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS
2177}
2178
f6c77cf1 2179SSize_t
f62ce20a 2180PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2181{
14a5cf38
JH
2182 STDCHAR *buf = (STDCHAR *) vbuf;
2183 if (f) {
263df5f1
JH
2184 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2185 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2186 SETERRNO(EBADF, SS_IVCHAN);
2187 return 0;
2188 }
14a5cf38 2189 while (count > 0) {
93c2c2ec
IZ
2190 get_cnt:
2191 {
14a5cf38
JH
2192 SSize_t avail = PerlIO_get_cnt(f);
2193 SSize_t take = 0;
2194 if (avail > 0)
bb7a0f54 2195 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
14a5cf38
JH
2196 if (take > 0) {
2197 STDCHAR *ptr = PerlIO_get_ptr(f);
2198 Copy(ptr, buf, take, STDCHAR);
2199 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2200 count -= take;
2201 buf += take;
93c2c2ec
IZ
2202 if (avail == 0) /* set_ptrcnt could have reset avail */
2203 goto get_cnt;
14a5cf38
JH
2204 }
2205 if (count > 0 && avail <= 0) {
2206 if (PerlIO_fill(f) != 0)
2207 break;
2208 }
93c2c2ec 2209 }
14a5cf38
JH
2210 }
2211 return (buf - (STDCHAR *) vbuf);
2212 }
f6c77cf1 2213 return 0;
f6c77cf1
NIS
2214}
2215
9e353e3b 2216IV
f62ce20a 2217PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2218{
96a5add6 2219 PERL_UNUSED_CONTEXT;
8772537c 2220 PERL_UNUSED_ARG(f);
14a5cf38 2221 return 0;
9e353e3b
NIS
2222}
2223
2224IV
f62ce20a 2225PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2226{
96a5add6 2227 PERL_UNUSED_CONTEXT;
8772537c 2228 PERL_UNUSED_ARG(f);
14a5cf38 2229 return -1;
06da4f11
NIS
2230}
2231
2232IV
f62ce20a 2233PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2234{
37725cdc
NIS
2235 IV code = -1;
2236 if (PerlIOValid(f)) {
2237 PerlIO *n = PerlIONext(f);
2238 code = PerlIO_flush(f);
2239 PerlIOBase(f)->flags &=
2240 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2241 while (PerlIOValid(n)) {
de009b76 2242 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS
2243 if (tab && tab->Close) {
2244 if ((*tab->Close)(aTHX_ n) != 0)
2245 code = -1;
2246 break;
2247 }
2248 else {
2249 PerlIOBase(n)->flags &=
2250 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2251 }
2252 n = PerlIONext(n);
2253 }
2254 }
2255 else {
2256 SETERRNO(EBADF, SS_IVCHAN);
2257 }
14a5cf38 2258 return code;
9e353e3b
NIS
2259}
2260
2261IV
f62ce20a 2262PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2263{
96a5add6 2264 PERL_UNUSED_CONTEXT;
04892f78 2265 if (PerlIOValid(f)) {
14a5cf38
JH
2266 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2267 }
2268 return 1;
9e353e3b
NIS
2269}
2270
2271IV
f62ce20a 2272PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2273{
96a5add6 2274 PERL_UNUSED_CONTEXT;
04892f78 2275 if (PerlIOValid(f)) {
14a5cf38
JH
2276 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2277 }
2278 return 1;
9e353e3b
NIS
2279}
2280
2281void
f62ce20a 2282PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2283{
04892f78 2284 if (PerlIOValid(f)) {
dcda55fc 2285 PerlIO * const n = PerlIONext(f);
14a5cf38 2286 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2287 if (PerlIOValid(n))
14a5cf38
JH
2288 PerlIO_clearerr(n);
2289 }
9e353e3b
NIS
2290}
2291
2292void
f62ce20a 2293PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2294{
96a5add6 2295 PERL_UNUSED_CONTEXT;
04892f78 2296 if (PerlIOValid(f)) {
14a5cf38
JH
2297 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2298 }
9e353e3b
NIS
2299}
2300
93a8090d
NIS
2301SV *
2302PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2303{
2304 if (!arg)
a0714e2c 2305 return NULL;
93a8090d
NIS
2306#ifdef sv_dup
2307 if (param) {
a951d81d
BL
2308 arg = sv_dup(arg, param);
2309 SvREFCNT_inc_simple_void_NN(arg);
2310 return arg;
93a8090d
NIS
2311 }
2312 else {
2313 return newSVsv(arg);
2314 }
2315#else
1b6737cc 2316 PERL_UNUSED_ARG(param);
93a8090d
NIS
2317 return newSVsv(arg);
2318#endif
2319}
2320
2321PerlIO *
ecdeb87c 2322PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2323{
1b6737cc 2324 PerlIO * const nexto = PerlIONext(o);
04892f78 2325 if (PerlIOValid(nexto)) {
de009b76 2326 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS
2327 if (tab && tab->Dup)
2328 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2329 else
2330 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS
2331 }
2332 if (f) {
dcda55fc 2333 PerlIO_funcs * const self = PerlIOBase(o)->tab;
a951d81d 2334 SV *arg = NULL;
93a8090d 2335 char buf[8];
fe5a182c 2336 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
cc6623a8
DM
2337 self ? self->name : "(Null)",
2338 (void*)f, (void*)o, (void*)param);
2339 if (self && self->Getarg)
210e727c 2340 arg = (*self->Getarg)(aTHX_ o, param, flags);
93a8090d 2341 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
f0720f70
RGS
2342 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2343 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
ef8d46e8 2344 SvREFCNT_dec(arg);
93a8090d
NIS
2345 }
2346 return f;
2347}
2348
27da23d5 2349/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d 2350
8b84d7dd 2351/* Must be called with PL_perlio_mutex locked. */
22c96fc1
NC
2352static void
2353S_more_refcounted_fds(pTHX_ const int new_fd) {
7a89be66 2354 dVAR;
22c96fc1 2355 const int old_max = PL_perlio_fd_refcnt_size;
f4ae5be6 2356 const int new_max = 16 + (new_fd & ~15);
22c96fc1
NC
2357 int *new_array;
2358
2359 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2360 old_max, new_fd, new_max);
2361
2362 if (new_fd < old_max) {
2363 return;
2364 }
2365
f4ae5be6
NC
2366 assert (new_max > new_fd);
2367
eae082a0
JH
2368 /* Use plain realloc() since we need this memory to be really
2369 * global and visible to all the interpreters and/or threads. */
2370 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
22c96fc1
NC
2371
2372 if (!new_array) {
8b84d7dd 2373#ifdef USE_ITHREADS
6cb8cb21 2374 MUTEX_UNLOCK(&PL_perlio_mutex);
22c96fc1
NC
2375#endif
2376 /* Can't use PerlIO to write as it allocates memory */
2377 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2378 PL_no_mem, strlen(PL_no_mem));
2379 my_exit(1);
2380 }
2381
2382 PL_perlio_fd_refcnt_size = new_max;
2383 PL_perlio_fd_refcnt = new_array;
2384
95b63a38
JH
2385 PerlIO_debug("Zeroing %p, %d\n",
2386 (void*)(new_array + old_max),
2387 new_max - old_max);
22c96fc1
NC
2388
2389 Zero(new_array + old_max, new_max - old_max, int);
2390}
2391
2392
93a8090d
NIS
2393void
2394PerlIO_init(pTHX)
2395{
8b84d7dd 2396 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
96a5add6 2397 PERL_UNUSED_CONTEXT;
93a8090d
NIS
2398}
2399
168d5872
NIS
2400void
2401PerlIOUnix_refcnt_inc(int fd)
2402{
27da23d5 2403 dTHX;
22c96fc1 2404 if (fd >= 0) {
97aff369 2405 dVAR;
22c96fc1 2406
8b84d7dd 2407#ifdef USE_ITHREADS
6cb8cb21 2408 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2409#endif
22c96fc1
NC
2410 if (fd >= PL_perlio_fd_refcnt_size)
2411 S_more_refcounted_fds(aTHX_ fd);
2412
27da23d5 2413 PL_perlio_fd_refcnt[fd]++;
8b84d7dd
RGS
2414 if (PL_perlio_fd_refcnt[fd] <= 0) {
2415 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2416 fd, PL_perlio_fd_refcnt[fd]);
2417 }
2418 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2419 fd, PL_perlio_fd_refcnt[fd]);
22c96fc1 2420
8b84d7dd 2421#ifdef USE_ITHREADS
6cb8cb21 2422 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2423#endif
8b84d7dd
RGS
2424 } else {
2425 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
168d5872
NIS
2426 }
2427}
2428
168d5872
NIS
2429int
2430PerlIOUnix_refcnt_dec(int fd)
2431{
27da23d5 2432 dTHX;
168d5872 2433 int cnt = 0;
22c96fc1 2434 if (fd >= 0) {
97aff369 2435 dVAR;
8b84d7dd 2436#ifdef USE_ITHREADS
6cb8cb21 2437 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2438#endif
8b84d7dd
RGS
2439 if (fd >= PL_perlio_fd_refcnt_size) {
2440 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2441 fd, PL_perlio_fd_refcnt_size);
2442 }
2443 if (PL_perlio_fd_refcnt[fd] <= 0) {
2444 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2445 fd, PL_perlio_fd_refcnt[fd]);
2446 }
27da23d5 2447 cnt = --PL_perlio_fd_refcnt[fd];
8b84d7dd
RGS
2448 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2449#ifdef USE_ITHREADS
6cb8cb21 2450 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2451#endif
8b84d7dd
RGS
2452 } else {
2453 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
168d5872
NIS
2454 }
2455 return cnt;
2456}
2457
2e0cfa16
FC
2458int
2459PerlIOUnix_refcnt(int fd)
2460{
2461 dTHX;
2462 int cnt = 0;
2463 if (fd >= 0) {
2464 dVAR;
2465#ifdef USE_ITHREADS
2466 MUTEX_LOCK(&PL_perlio_mutex);
2467#endif
2468 if (fd >= PL_perlio_fd_refcnt_size) {
2469 /* diag_listed_as: refcnt: fd %d%s */
2470 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2471 fd, PL_perlio_fd_refcnt_size);
2472 }
2473 if (PL_perlio_fd_refcnt[fd] <= 0) {
2474 /* diag_listed_as: refcnt: fd %d%s */
2475 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2476 fd, PL_perlio_fd_refcnt[fd]);
2477 }
2478 cnt = PL_perlio_fd_refcnt[fd];
2479#ifdef USE_ITHREADS
2480 MUTEX_UNLOCK(&PL_perlio_mutex);
2481#endif
2482 } else {
2483 /* diag_listed_as: refcnt: fd %d%s */
2484 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2485 }
2486 return cnt;
2487}
2488
694c95cf
JH
2489void
2490PerlIO_cleanup(pTHX)
2491{
97aff369 2492 dVAR;
694c95cf
JH
2493 int i;
2494#ifdef USE_ITHREADS
a25429c6 2495 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
9f4bd222
NIS
2496#else
2497 PerlIO_debug("Cleanup layers\n");
694c95cf 2498#endif
e47547a8 2499
694c95cf
JH
2500 /* Raise STDIN..STDERR refcount so we don't close them */
2501 for (i=0; i < 3; i++)
2502 PerlIOUnix_refcnt_inc(i);
2503 PerlIO_cleantable(aTHX_ &PL_perlio);
2504 /* Restore STDIN..STDERR refcount */
2505 for (i=0; i < 3; i++)
2506 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS
2507
2508 if (PL_known_layers) {
2509 PerlIO_list_free(aTHX_ PL_known_layers);
2510 PL_known_layers = NULL;
2511 }
27da23d5 2512 if (PL_def_layerlist) {
9f4bd222
NIS
2513 PerlIO_list_free(aTHX_ PL_def_layerlist);
2514 PL_def_layerlist = NULL;
2515 }
6cb8cb21
RGS
2516}
2517
0934c9d9 2518void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
6cb8cb21 2519{
53d44271 2520 dVAR;
4f3da17a
DM
2521#if 0
2522/* XXX we can't rely on an interpreter being present at this late stage,
2523 XXX so we can't use a function like PerlLIO_write that relies on one
2524 being present (at least in win32) :-(.
2525 Disable for now.
2526*/
6cb8cb21
RGS
2527#ifdef DEBUGGING
2528 {
2529 /* By now all filehandles should have been closed, so any
2530 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2531 * errors. */
77db880c
JH
2532#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2533#define PERLIO_TEARDOWN_MESSAGE_FD 2
2534 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
6cb8cb21
RGS
2535 int i;
2536 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
77db880c
JH
2537 if (PL_perlio_fd_refcnt[i]) {
2538 const STRLEN len =
2539 my_snprintf(buf, sizeof(buf),
2540 "PerlIO_teardown: fd %d refcnt=%d\n",
2541 i, PL_perlio_fd_refcnt[i]);
2542 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2543 }
6cb8cb21
RGS
2544 }
2545 }
2546#endif
4f3da17a 2547#endif
eae082a0
JH
2548 /* Not bothering with PL_perlio_mutex since by now
2549 * all the interpreters are gone. */
1cd82952
RGS
2550 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2551 && PL_perlio_fd_refcnt) {
eae082a0 2552 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO
2553 PL_perlio_fd_refcnt = NULL;
2554 PL_perlio_fd_refcnt_size = 0;
1cd82952 2555 }
694c95cf
JH
2556}
2557
9e353e3b 2558/*--------------------------------------------------------------------------------------*/
14a5cf38 2559/*
71200d45 2560 * Bottom-most level for UNIX-like case
14a5cf38 2561 */
9e353e3b 2562
14a5cf38 2563typedef struct {
22569500
NIS
2564 struct _PerlIO base; /* The generic part */
2565 int fd; /* UNIX like file descriptor */
2566 int oflags; /* open/fcntl flags */
9e353e3b
NIS
2567} PerlIOUnix;
2568
abf9167d
DM
2569static void
2570S_lockcnt_dec(pTHX_ const void* f)
2571{
2572 PerlIO_lockcnt((PerlIO*)f)--;
2573}
2574
2575
2576/* call the signal handler, and if that handler happens to clear
2577 * this handle, free what we can and return true */
2578
2579static bool
2580S_perlio_async_run(pTHX_ PerlIO* f) {
2581 ENTER;
2582 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2583 PerlIO_lockcnt(f)++;
2584 PERL_ASYNC_CHECK();
2585 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2586 return 0;
2587 /* we've just run some perl-level code that could have done
2588 * anything, including closing the file or clearing this layer.
2589 * If so, free any lower layers that have already been
2590 * cleared, then return an error. */
2591 while (PerlIOValid(f) &&
2592 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2593 {
2594 const PerlIOl *l = *f;
2595 *f = l->next;
2596 Safefree(l);
2597 }
2598 return 1;
2599}
2600
6f9d8c32 2601int
9e353e3b 2602PerlIOUnix_oflags(const char *mode)
760ac839 2603{
14a5cf38 2604 int oflags = -1;
3b6c1aba 2605 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH
2606 mode++;
2607 switch (*mode) {
2608 case 'r':
2609 oflags = O_RDONLY;
2610 if (*++mode == '+') {
2611 oflags = O_RDWR;
2612 mode++;
2613 }
2614 break;
2615
2616 case 'w':
2617 oflags = O_CREAT | O_TRUNC;
2618 if (*++mode == '+') {
2619 oflags |= O_RDWR;
2620 mode++;
2621 }
2622 else
2623 oflags |= O_WRONLY;
2624 break;
2625
2626 case 'a':
2627 oflags = O_CREAT | O_APPEND;
2628 if (*++mode == '+') {
2629 oflags |= O_RDWR;
2630 mode++;
2631 }
2632 else
2633 oflags |= O_WRONLY;
2634 break;
2635 }
2636 if (*mode == 'b') {
2637 oflags |= O_BINARY;
2638 oflags &= ~O_TEXT;
2639 mode++;
2640 }
2641 else if (*mode == 't') {
2642 oflags |= O_TEXT;
2643 oflags &= ~O_BINARY;
2644 mode++;
2645 }
2646 /*
71200d45 2647 * Always open in binary mode
14a5cf38
JH
2648 */
2649 oflags |= O_BINARY;
2650 if (*mode || oflags == -1) {
93189314 2651 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2652 oflags = -1;
2653 }
2654 return oflags;
9e353e3b
NIS
2655}
2656
2657IV
f62ce20a 2658PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2659{
96a5add6 2660 PERL_UNUSED_CONTEXT;
14a5cf38 2661 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS
2662}
2663
aa063c35
NIS
2664static void
2665PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2666{
de009b76 2667 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2668#if defined(WIN32)
aa063c35
NIS
2669 Stat_t st;
2670 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2671 if (!S_ISREG(st.st_mode)) {
aa063c35 2672 PerlIO_debug("%d is not regular file\n",fd);
6caa5a9c
NIS
2673 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2674 }
aa063c35
NIS
2675 else {
2676 PerlIO_debug("%d _is_ a regular file\n",fd);
2677 }
6caa5a9c
NIS
2678 }
2679#endif
aa063c35
NIS
2680 s->fd = fd;
2681 s->oflags = imode;
2682 PerlIOUnix_refcnt_inc(fd);
96a5add6 2683 PERL_UNUSED_CONTEXT;
aa063c35
NIS
2684}
2685
2686IV
2687PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2688{
2689 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2690 if (*PerlIONext(f)) {
4b069b44 2691 /* We never call down so do any pending stuff now */
03c0554d 2692 PerlIO_flush(PerlIONext(f));
14a5cf38 2693 /*
71200d45 2694 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2695 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2696 * Should the value on NULL mode be 0 or -1?
14a5cf38 2697 */
acbd16bf 2698 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2699 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH
2700 }
2701 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2702
14a5cf38 2703 return code;
4b803d04
NIS
2704}
2705
c2fcde81
JH
2706IV
2707PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2708{
de009b76 2709 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2710 Off_t new_loc;
96a5add6 2711 PERL_UNUSED_CONTEXT;
c2fcde81
JH
2712 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2713#ifdef ESPIPE
2714 SETERRNO(ESPIPE, LIB_INVARG);
2715#else
2716 SETERRNO(EINVAL, LIB_INVARG);
2717#endif
2718 return -1;
2719 }
0723351e
NC
2720 new_loc = PerlLIO_lseek(fd, offset, whence);
2721 if (new_loc == (Off_t) - 1)
dcda55fc 2722 return -1;
c2fcde81
JH
2723 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2724 return 0;
2725}
2726
9e353e3b 2727PerlIO *
14a5cf38
JH
2728PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2729 IV n, const char *mode, int fd, int imode,
2730 int perm, PerlIO *f, int narg, SV **args)
2731{
d9dac8cd 2732 if (PerlIOValid(f)) {
cc6623a8 2733 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2734 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH
2735 }
2736 if (narg > 0) {
3b6c1aba 2737 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH
2738 mode++;
2739 else {
2740 imode = PerlIOUnix_oflags(mode);
5e2ce0f3
CB
2741#ifdef VMS
2742 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2743#else
14a5cf38 2744 perm = 0666;
5e2ce0f3 2745#endif
14a5cf38
JH
2746 }
2747 if (imode != -1) {
e62f0680 2748 const char *path = SvPV_nolen_const(*args);
14a5cf38
JH
2749 fd = PerlLIO_open3(path, imode, perm);
2750 }
2751 }
2752 if (fd >= 0) {
3b6c1aba 2753 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2754 mode++;
2755 if (!f) {
2756 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS
2757 }
2758 if (!PerlIOValid(f)) {
a33cf58c
NIS
2759 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2760 return NULL;
2761 }
d9dac8cd 2762 }
aa063c35 2763 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2764 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH
2765 if (*mode == IoTYPE_APPEND)
2766 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH
2767 return f;
2768 }
2769 else {
2770 if (f) {
6f207bd3 2771 NOOP;
14a5cf38 2772 /*
71200d45 2773 * FIXME: pop layers ???
14a5cf38
JH
2774 */
2775 }
2776 return NULL;
2777 }
9e353e3b
NIS
2778}
2779
71200d45 2780PerlIO *
ecdeb87c 2781PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2782{
dcda55fc 2783 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2784 int fd = os->fd;
ecdeb87c
NIS
2785 if (flags & PERLIO_DUP_FD) {
2786 fd = PerlLIO_dup(fd);
2787 }
22c96fc1 2788 if (fd >= 0) {
ecdeb87c 2789 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS
2790 if (f) {
2791 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2792 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS
2793 return f;
2794 }
71200d45
NIS
2795 }
2796 return NULL;
2797}
2798
2799
9e353e3b 2800SSize_t
f62ce20a 2801PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2802{
97aff369 2803 dVAR;
abf9167d
DM
2804 int fd;
2805 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2806 return -1;
2807 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2808#ifdef PERLIO_STD_SPECIAL
2809 if (fd == 0)
2810 return PERLIO_STD_IN(fd, vbuf, count);
2811#endif
81428673 2812 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2813 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2814 return 0;
1fd8f4ce 2815 }
14a5cf38 2816 while (1) {
b464bac0 2817 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2818 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2819 if (len < 0) {
2820 if (errno != EAGAIN) {
2821 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2822 }
2823 }
2824 else if (len == 0 && count != 0) {
14a5cf38 2825 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS
2826 SETERRNO(0,0);
2827 }
14a5cf38
JH
2828 return len;
2829 }
abf9167d
DM
2830 /* EINTR */
2831 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2832 return -1;
14a5cf38 2833 }
b464bac0 2834 /*NOTREACHED*/
9e353e3b
NIS
2835}
2836
2837SSize_t
f62ce20a 2838PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2839{
97aff369 2840 dVAR;
abf9167d
DM
2841 int fd;
2842 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2843 return -1;
2844 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2845#ifdef PERLIO_STD_SPECIAL
2846 if (fd == 1 || fd == 2)
2847 return PERLIO_STD_OUT(fd, vbuf, count);
2848#endif
14a5cf38 2849 while (1) {
de009b76 2850 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2851 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2852 if (len < 0) {
2853 if (errno != EAGAIN) {
2854 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2855 }
2856 }
14a5cf38
JH
2857 return len;
2858 }
abf9167d
DM
2859 /* EINTR */
2860 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2861 return -1;
06da4f11 2862 }
1b6737cc 2863 /*NOTREACHED*/
9e353e3b
NIS
2864}
2865
9e353e3b 2866Off_t
f62ce20a 2867PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2868{
96a5add6
AL
2869 PERL_UNUSED_CONTEXT;
2870
14a5cf38 2871 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2872}
2873
2556f95e
GF
2874
2875IV
2376d97d 2876PerlIOUnix_close(pTHX_ PerlIO *f)
2556f95e 2877{
97aff369 2878 dVAR;
de009b76 2879 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2880 int code = 0;
168d5872
NIS
2881 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2882 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2883 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2884 return 0;
22569500 2885 }
93a8090d
NIS
2886 }
2887 else {
93189314 2888 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2889 return -1;
2890 }
14a5cf38
JH
2891 while (PerlLIO_close(fd) != 0) {
2892 if (errno != EINTR) {
2893 code = -1;
2894 break;
2895 }
abf9167d
DM
2896 /* EINTR */
2897 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2898 return -1;
14a5cf38
JH
2899 }
2900 if (code == 0) {
2901 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2902 }
2903 return code;
9e353e3b
NIS
2904}
2905
27da23d5 2906PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2907 sizeof(PerlIO_funcs),
14a5cf38
JH
2908 "unix",
2909 sizeof(PerlIOUnix),
2910 PERLIO_K_RAW,
2911 PerlIOUnix_pushed,
2376d97d 2912 PerlIOBase_popped,
14a5cf38 2913 PerlIOUnix_open,
86e05cf2 2914 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2915 NULL,
2916 PerlIOUnix_fileno,
71200d45 2917 PerlIOUnix_dup,
14a5cf38
JH
2918 PerlIOUnix_read,
2919 PerlIOBase_unread,
2920 PerlIOUnix_write,
2921 PerlIOUnix_seek,
2922 PerlIOUnix_tell,
2923 PerlIOUnix_close,
22569500
NIS
2924 PerlIOBase_noop_ok, /* flush */
2925 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2926 PerlIOBase_eof,
2927 PerlIOBase_error,
2928 PerlIOBase_clearerr,
2929 PerlIOBase_setlinebuf,
22569500
NIS
2930 NULL, /* get_base */
2931 NULL, /* get_bufsiz */
2932 NULL, /* get_ptr */
2933 NULL, /* get_cnt */
2934 NULL, /* set_ptrcnt */
9e353e3b
NIS
2935};
2936
2937/*--------------------------------------------------------------------------------------*/
14a5cf38 2938/*
71200d45 2939 * stdio as a layer
14a5cf38 2940 */
9e353e3b 2941
313e59c8
NIS
2942#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2943/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2944 broken by the last second glibc 2.3 fix
2945 */
2946#define STDIO_BUFFER_WRITABLE
2947#endif
2948
2949
14a5cf38
JH
2950typedef struct {
2951 struct _PerlIO base;
22569500 2952 FILE *stdio; /* The stream */
9e353e3b
NIS
2953} PerlIOStdio;
2954
2955IV
f62ce20a 2956PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2957{
96a5add6
AL
2958 PERL_UNUSED_CONTEXT;
2959
c4420975
AL
2960 if (PerlIOValid(f)) {
2961 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2962 if (s)
2963 return PerlSIO_fileno(s);
439ba545
NIS
2964 }
2965 errno = EBADF;
2966 return -1;
9e353e3b
NIS
2967}
2968
766a733e 2969char *
14a5cf38
JH
2970PerlIOStdio_mode(const char *mode, char *tmode)
2971{
de009b76 2972 char * const ret = tmode;
a0625d38
SR
2973 if (mode) {
2974 while (*mode) {
2975 *tmode++ = *mode++;
2976 }
14a5cf38 2977 }
95005ad8 2978#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2979 *tmode++ = 'b';
2980#endif
14a5cf38
JH
2981 *tmode = '\0';
2982 return ret;
2983}
2984
4b803d04 2985IV
2dc2558e 2986PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2987{
1fd8f4ce
NIS
2988 PerlIO *n;
2989 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2990 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS
2991 if (toptab == tab) {
2992 /* Top is already stdio - pop self (duplicate) and use original */
2993 PerlIO_pop(aTHX_ f);
2994 return 0;
2995 } else {
de009b76 2996 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2997 char tmode[8];
2998 FILE *stdio;
81428673 2999 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
3000 mode = PerlIOStdio_mode(mode, tmode)))) {
3001 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3002 /* We never call down so do any pending stuff now */
3003 PerlIO_flush(PerlIONext(f));
81428673 3004 }
1fd8f4ce
NIS
3005 else {
3006 return -1;
3007 }
3008 }
14a5cf38 3009 }
2dc2558e 3010 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
3011}
3012
22569500 3013
9e353e3b 3014PerlIO *
4b069b44 3015PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 3016{
14a5cf38
JH
3017 dTHX;
3018 PerlIO *f = NULL;
3019 if (stdio) {
22569500 3020 PerlIOStdio *s;
4b069b44
NIS
3021 if (!mode || !*mode) {
3022 /* We need to probe to see how we can open the stream
3023 so start with read/write and then try write and read
3024 we dup() so that we can fclose without loosing the fd.
3025
3026 Note that the errno value set by a failing fdopen
3027 varies between stdio implementations.
3028 */
de009b76 3029 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 3030 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 3031 if (!f2) {
a33cf58c 3032 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
3033 }
3034 if (!f2) {
a33cf58c 3035 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
3036 }
3037 if (!f2) {
3038 /* Don't seem to be able to open */
3039 PerlLIO_close(fd);
3040 return f;
3041 }
3042 fclose(f2);
22569500 3043 }
a0714e2c 3044 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS
3045 s = PerlIOSelf(f, PerlIOStdio);
3046 s->stdio = stdio;
c586124f 3047 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 3048 }
14a5cf38
JH
3049 }
3050 return f;
9e353e3b
NIS
3051}
3052
3053PerlIO *
14a5cf38
JH
3054PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3055 IV n, const char *mode, int fd, int imode,
3056 int perm, PerlIO *f, int narg, SV **args)
3057{
3058 char tmode[8];
d9dac8cd 3059 if (PerlIOValid(f)) {
dcda55fc
AL
3060 const char * const path = SvPV_nolen_const(*args);
3061 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS
3062 FILE *stdio;
3063 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3064 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH
3065 s->stdio);
3066 if (!s->stdio)
3067 return NULL;
3068 s->stdio = stdio;
1751d015 3069 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
3070 return f;
3071 }
3072 else {
3073 if (narg > 0) {
dcda55fc 3074 const char * const path = SvPV_nolen_const(*args);
3b6c1aba 3075 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
3076 mode++;
3077 fd = PerlLIO_open3(path, imode, perm);
3078 }
3079 else {
95005ad8
GH
3080 FILE *stdio;
3081 bool appended = FALSE;
3082#ifdef __CYGWIN__
3083 /* Cygwin wants its 'b' early. */
3084 appended = TRUE;
3085 mode = PerlIOStdio_mode(mode, tmode);
3086#endif
3087 stdio = PerlSIO_fopen(path, mode);
6f0313ac 3088 if (stdio) {
6f0313ac
JH
3089 if (!f) {
3090 f = PerlIO_allocate(aTHX);
3091 }
95005ad8
GH
3092 if (!appended)
3093 mode = PerlIOStdio_mode(mode, tmode);
3094 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3095 if (f) {
0f0f9e2b
JH
3096 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3097 PerlIOUnix_refcnt_inc(fileno(stdio));
3098 } else {
3099 PerlSIO_fclose(stdio);
6f0313ac
JH
3100 }
3101 return f;
3102 }
3103 else {
3104 return NULL;
3105 }
14a5cf38
JH
3106 }
3107 }
3108 if (fd >= 0) {
3109 FILE *stdio = NULL;
3110 int init = 0;
3b6c1aba 3111 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
3112 init = 1;
3113 mode++;
3114 }
3115 if (init) {
3116 switch (fd) {
3117 case 0:
3118 stdio = PerlSIO_stdin;
3119 break;
3120 case 1:
3121 stdio = PerlSIO_stdout;
3122 break;
3123 case 2:
3124 stdio = PerlSIO_stderr;
3125 break;
3126 }
3127 }
3128 else {
3129 stdio = PerlSIO_fdopen(fd, mode =
3130 PerlIOStdio_mode(mode, tmode));
3131 }
3132 if (stdio) {
d9dac8cd
NIS
3133 if (!f) {
3134 f = PerlIO_allocate(aTHX);
3135 }
a33cf58c 3136 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba
JH
3137 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3138 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 3139 }
14a5cf38
JH
3140 return f;
3141 }
3142 }
3143 }
ee518936 3144 return NULL;
9e353e3b
NIS
3145}
3146
1751d015 3147PerlIO *
ecdeb87c 3148PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
3149{
3150 /* This assumes no layers underneath - which is what
3151 happens, but is not how I remember it. NI-S 2001/10/16
3152 */
ecdeb87c 3153 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 3154 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 3155 const int fd = fileno(stdio);
9217ff3f 3156 char mode[8];
ecdeb87c 3157 if (flags & PERLIO_DUP_FD) {
de009b76 3158 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
3159 if (dfd >= 0) {
3160 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3161 goto set_this;
ecdeb87c
NIS
3162 }
3163 else {
6f207bd3 3164 NOOP;
ecdeb87c
NIS
3165 /* FIXME: To avoid messy error recovery if dup fails
3166 re-use the existing stdio as though flag was not set
3167 */
3168 }
3169 }
9217ff3f
NIS
3170 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3171 set_this:
694c95cf 3172 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
40596bc5
SP
3173 if(stdio) {
3174 PerlIOUnix_refcnt_inc(fileno(stdio));
3175 }
1751d015
NIS
3176 }
3177 return f;
3178}
3179
0d7a5398
NIS
3180static int
3181PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3182{
96a5add6
AL
3183 PERL_UNUSED_CONTEXT;
3184
0d7a5398 3185 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3186 * PerlIO_set_fileno() support from Configure
0d7a5398 3187 */
ef8eacb8
AT
3188# if defined(__UCLIBC__)
3189 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3190 f->__filedes = -1;
3191 return 1;
3192# elif defined(__GLIBC__)
0d7a5398 3193 /* There may be a better way for GLIBC:
37725cdc 3194 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
3195 */
3196 f->_fileno = -1;
3197 return 1;
3198# elif defined(__sun__)
f5992bc4 3199 PERL_UNUSED_ARG(f);
cfedb851 3200 return 0;
0d7a5398
NIS
3201# elif defined(__hpux)
3202 f->__fileH = 0xff;
3203 f->__fileL = 0xff;
3204 return 1;
9837d373 3205 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3206 your platform does not have special entry try this one.
9837d373
NIS
3207 [For OSF only have confirmation for Tru64 (alpha)
3208 but assume other OSFs will be similar.]
37725cdc 3209 */
9837d373 3210# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
3211 f->_file = -1;
3212 return 1;
3213# elif defined(__FreeBSD__)
3214 /* There may be a better way on FreeBSD:
37725cdc
NIS
3215 - we could insert a dummy func in the _close function entry
3216 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3217 */
3218 f->_file = -1;
0c49ea6a
SU
3219 return 1;
3220# elif defined(__OpenBSD__)
3221 /* There may be a better way on OpenBSD:
3222 - we could insert a dummy func in the _close function entry
3223 f->_close = (int (*)(void *)) dummy_close;
3224 */
3225 f->_file = -1;
0d7a5398 3226 return 1;
59ad941d
IZ
3227# elif defined(__EMX__)
3228 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3229 f->_handle = -1;
3230 return 1;
0d7a5398
NIS
3231# elif defined(__CYGWIN__)
3232 /* There may be a better way on CYGWIN:
37725cdc
NIS
3233 - we could insert a dummy func in the _close function entry
3234 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3235 */
3236 f->_file = -1;
3237 return 1;
3238# elif defined(WIN32)
3239# if defined(__BORLANDC__)
3240 f->fd = PerlLIO_dup(fileno(f));
b475b3e6
JH
3241# elif defined(UNDER_CE)
3242 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3243 structure at all
3244 */
0d7a5398
NIS
3245# else
3246 f->_file = -1;
3247# endif
3248 return 1;
3249# else
3250#if 0
37725cdc 3251 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3252 (which isn't thread safe) instead
37725cdc 3253 */
0d7a5398
NIS
3254# error "Don't know how to set FILE.fileno on your platform"
3255#endif
8772537c 3256 PERL_UNUSED_ARG(f);
0d7a5398
NIS
3257 return 0;
3258# endif
3259}
3260
1751d015 3261IV
f62ce20a 3262PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3263{
c4420975 3264 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
3265 if (!stdio) {
3266 errno = EBADF;
3267 return -1;
3268 }
9217ff3f 3269 else {
de009b76 3270 const int fd = fileno(stdio);
0d7a5398 3271 int invalidate = 0;
bbfd922f 3272 IV result = 0;
1d791a44 3273 int dupfd = -1;
4ee39169 3274 dSAVEDERRNO;
a2e578da
MHM
3275#ifdef USE_ITHREADS
3276 dVAR;
3277#endif
0d7a5398 3278#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
3279 /* Socks lib overrides close() but stdio isn't linked to
3280 that library (though we are) - so we must call close()
3281 on sockets on stdio's behalf.
3282 */
0d7a5398
NIS
3283 int optval;
3284 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3285 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3286 invalidate = 1;
0d7a5398 3287#endif
d8723f43
NC
3288 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3289 that a subsequent fileno() on it returns -1. Don't want to croak()
3290 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3291 trying to close an already closed handle which somehow it still has
3292 a reference to. (via.xs, I'm looking at you). */
3293 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3294 /* File descriptor still in use */
0d7a5398 3295 invalidate = 1;
d8723f43 3296 }
0d7a5398 3297 if (invalidate) {
6b4ce6c8
AL
3298 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3299 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3300 return 0;
3301 if (stdio == stdout || stdio == stderr)
3302 return PerlIO_flush(f);
37725cdc
NIS
3303 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3304 Use Sarathy's trick from maint-5.6 to invalidate the
3305 fileno slot of the FILE *
3306 */
bbfd922f 3307 result = PerlIO_flush(f);
4ee39169 3308 SAVE_ERRNO;
6b4ce6c8 3309 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
711e8db2 3310 if (!invalidate) {
9bab90c0
NC
3311#ifdef USE_ITHREADS
3312 MUTEX_LOCK(&PL_perlio_mutex);
5ca745d2
NC
3313 /* Right. We need a mutex here because for a brief while we
3314 will have the situation that fd is actually closed. Hence if
3315 a second thread were to get into this block, its dup() would
3316 likely return our fd as its dupfd. (after all, it is closed)
9bab90c0
NC
3317 Then if we get to the dup2() first, we blat the fd back
3318 (messing up its temporary as a side effect) only for it to
3319 then close its dupfd (== our fd) in its close(dupfd) */
3320
3321 /* There is, of course, a race condition, that any other thread
3322 trying to input/output/whatever on this fd will be stuffed
5ca745d2
NC
3323 for the duration of this little manoeuvrer. Perhaps we
3324 should hold an IO mutex for the duration of every IO
3325 operation if we know that invalidate doesn't work on this
3326 platform, but that would suck, and could kill performance.
9bab90c0
NC
3327
3328 Except that correctness trumps speed.
3329 Advice from klortho #11912. */
3330#endif
6b4ce6c8 3331 dupfd = PerlLIO_dup(fd);
711e8db2 3332#ifdef USE_ITHREADS
9bab90c0
NC
3333 if (dupfd < 0) {
3334 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2
NC
3335 /* Oh cXap. This isn't going to go well. Not sure if we can
3336 recover from here, or if closing this particular FILE *
3337 is a good idea now. */
3338 }
3339#endif
3340 }
94ccb807
JH
3341 } else {
3342 SAVE_ERRNO; /* This is here only to silence compiler warnings */
37725cdc 3343 }
0d7a5398 3344 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3345 /* We treat error from stdio as success if we invalidated
3346 errno may NOT be expected EBADF
e8529473
NIS
3347 */
3348 if (invalidate && result != 0) {
4ee39169 3349 RESTORE_ERRNO;
0d7a5398 3350 result = 0;
37725cdc 3351 }
6b4ce6c8
AL
3352#ifdef SOCKS5_VERSION_NAME
3353 /* in SOCKS' case, let close() determine return value */
3354 result = close(fd);
3355#endif
1d791a44 3356 if (dupfd >= 0) {
0d7a5398 3357 PerlLIO_dup2(dupfd,fd);
9bab90c0 3358 PerlLIO_close(dupfd);
711e8db2 3359#ifdef USE_ITHREADS
9bab90c0 3360 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2 3361#endif
9217ff3f
NIS
3362 }
3363 return result;
37725cdc 3364 }
1751d015
NIS
3365}
3366
9e353e3b 3367SSize_t
f62ce20a 3368PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3369{
97aff369 3370 dVAR;
abf9167d 3371 FILE * s;
14a5cf38 3372 SSize_t got = 0;
abf9167d
DM
3373 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3374 return -1;
3375 s = PerlIOSelf(f, PerlIOStdio)->stdio;
4d948241
NIS
3376 for (;;) {
3377 if (count == 1) {
3378 STDCHAR *buf = (STDCHAR *) vbuf;
3379 /*
3380 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3381 * stdio does not do that for fread()
3382 */
de009b76 3383 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3384 if (ch != EOF) {
3385 *buf = ch;
3386 got = 1;
3387 }
14a5cf38 3388 }
4d948241
NIS
3389 else
3390 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3391 if (got == 0 && PerlSIO_ferror(s))
3392 got = -1;
42a7a32f 3393 if (got >= 0 || errno != EINTR)
4d948241 3394 break;
abf9167d
DM
3395 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3396 return -1;
42a7a32f 3397 SETERRNO(0,0); /* just in case */
14a5cf38 3398 }
14a5cf38 3399 return got;
9e353e3b
NIS
3400}
3401
3402SSize_t
f62ce20a 3403PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3404{
14a5cf38 3405 SSize_t unread = 0;
c4420975 3406 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3407
313e59c8 3408#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3409 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3410 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3411 STDCHAR *base = PerlIO_get_base(f);
3412 SSize_t cnt = PerlIO_get_cnt(f);
3413 STDCHAR *ptr = PerlIO_get_ptr(f);
3414 SSize_t avail = ptr - base;
3415 if (avail > 0) {
3416 if (avail > count) {
3417 avail = count;
3418 }
3419 ptr -= avail;
3420 Move(buf-avail,ptr,avail,STDCHAR);
3421 count -= avail;
3422 unread += avail;
3423 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3424 if (PerlSIO_feof(s) && unread >= 0)
3425 PerlSIO_clearerr(s);
3426 }
3427 }
313e59c8
NIS
3428 else
3429#endif
3430 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3431 /* We can get pointer to buffer but not its base
3432 Do ungetc() but check chars are ending up in the
3433 buffer
3434 */
3435 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3436 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3437 while (count > 0) {
de009b76 3438 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3439 if (ungetc(ch,s) != ch) {
3440 /* ungetc did not work */
3441 break;
3442 }
3443 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3444 /* Did not change pointer as expected */
3445 fgetc(s); /* get char back again */
3446 break;
3447 }
3448 /* It worked ! */
3449 count--;
3450 unread++;
93679785
NIS
3451 }
3452 }
3453
3454 if (count > 0) {
3455 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3456 }
3457 return unread;
9e353e3b
NIS
3458}
3459
3460SSize_t
f62ce20a 3461PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3462{
97aff369 3463 dVAR;
4d948241 3464 SSize_t got;
abf9167d
DM
3465 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3466 return -1;
4d948241
NIS
3467 for (;;) {
3468 got = PerlSIO_fwrite(vbuf, 1, count,
3469 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3470 if (got >= 0 || errno != EINTR)
4d948241 3471 break;
abf9167d
DM
3472 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3473 return -1;
42a7a32f 3474 SETERRNO(0,0); /* just in case */
4d948241
NIS
3475 }
3476 return got;
9e353e3b
NIS
3477}
3478
94a175e1 3479IV
f62ce20a 3480PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3481{
c4420975 3482 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3483 PERL_UNUSED_CONTEXT;
3484
94a175e1 3485 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3486}
3487
3488Off_t
f62ce20a 3489PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3490{
c4420975 3491 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3492 PERL_UNUSED_CONTEXT;
3493
94a175e1 3494 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3495}
3496
3497IV
f62ce20a 3498PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3499{
c4420975 3500 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3501 PERL_UNUSED_CONTEXT;
3502
14a5cf38
JH
3503 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3504 return PerlSIO_fflush(stdio);
3505 }
3506 else {
6f207bd3 3507 NOOP;
88b61e10 3508#if 0
14a5cf38
JH
3509 /*
3510 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3511 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3512 * design is to do _this_ but not have layer above flush this
71200d45 3513 * layer read-to-read
14a5cf38
JH
3514 */
3515 /*
71200d45 3516 * Not writeable - sync by attempting a seek
14a5cf38 3517 */
4ee39169 3518 dSAVE_ERRNO;
14a5cf38 3519 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3520 RESTORE_ERRNO;
88b61e10 3521#endif
14a5cf38
JH
3522 }
3523 return 0;
9e353e3b
NIS
3524}
3525
3526IV
f62ce20a 3527PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3528{
96a5add6
AL
3529 PERL_UNUSED_CONTEXT;
3530
14a5cf38 3531 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3532}
3533
3534IV
f62ce20a 3535PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3536{
96a5add6
AL
3537 PERL_UNUSED_CONTEXT;
3538