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