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