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