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