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