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