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