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