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