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