This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PL_in_load_module only has values 0 and 1, so can be a bool instead of int.
[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
NIS
1213 if (tab->fsize != sizeof(PerlIO_funcs)) {
1214 mismatch:
1215 Perl_croak(aTHX_ "Layer does not match this perl");
1216 }
1217 if (tab->size) {
b464bac0 1218 PerlIOl *l;
2dc2558e
NIS
1219 if (tab->size < sizeof(PerlIOl)) {
1220 goto mismatch;
1221 }
1222 /* Real layer with a data area */
002e75cf
JH
1223 if (f) {
1224 char *temp;
1225 Newxz(temp, tab->size, char);
1226 l = (PerlIOl*)temp;
1227 if (l) {
1228 l->next = *f;
1229 l->tab = (PerlIO_funcs*) tab;
1230 *f = l;
1231 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1232 (void*)f, tab->name,
1233 (mode) ? mode : "(Null)", (void*)arg);
1234 if (*l->tab->Pushed &&
1235 (*l->tab->Pushed)
1236 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1237 PerlIO_pop(aTHX_ f);
1238 return NULL;
1239 }
2dc2558e 1240 }
002e75cf
JH
1241 else
1242 return NULL;
2dc2558e
NIS
1243 }
1244 }
1245 else if (f) {
1246 /* Pseudo-layer where push does its own stack adjust */
00f51856
NIS
1247 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1248 (mode) ? mode : "(Null)", (void*)arg);
210e727c 1249 if (tab->Pushed &&
27da23d5 1250 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
210e727c 1251 return NULL;
14a5cf38
JH
1252 }
1253 }
1254 return f;
60382766
NIS
1255}
1256
dfebf958 1257IV
86e05cf2
NIS
1258PerlIOBase_binmode(pTHX_ PerlIO *f)
1259{
1260 if (PerlIOValid(f)) {
1261 /* Is layer suitable for raw stream ? */
1262 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1263 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1264 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1265 }
1266 else {
1267 /* Not suitable - pop it */
1268 PerlIO_pop(aTHX_ f);
1269 }
1270 return 0;
1271 }
1272 return -1;
1273}
1274
1275IV
2dc2558e 1276PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
dfebf958 1277{
8772537c
AL
1278 PERL_UNUSED_ARG(mode);
1279 PERL_UNUSED_ARG(arg);
1280 PERL_UNUSED_ARG(tab);
86e05cf2 1281
04892f78 1282 if (PerlIOValid(f)) {
86e05cf2 1283 PerlIO *t;
de009b76 1284 const PerlIOl *l;
14a5cf38 1285 PerlIO_flush(f);
86e05cf2
NIS
1286 /*
1287 * Strip all layers that are not suitable for a raw stream
1288 */
1289 t = f;
1290 while (t && (l = *t)) {
1291 if (l->tab->Binmode) {
1292 /* Has a handler - normal case */
9d97e8b8 1293 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
86e05cf2
NIS
1294 if (*t == l) {
1295 /* Layer still there - move down a layer */
1296 t = PerlIONext(t);
1297 }
1298 }
1299 else {
1300 return -1;
1301 }
14a5cf38
JH
1302 }
1303 else {
86e05cf2
NIS
1304 /* No handler - pop it */
1305 PerlIO_pop(aTHX_ t);
14a5cf38
JH
1306 }
1307 }
86e05cf2
NIS
1308 if (PerlIOValid(f)) {
1309 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1310 return 0;
1311 }
14a5cf38
JH
1312 }
1313 return -1;
dfebf958
NIS
1314}
1315
ac27b0f5 1316int
14a5cf38 1317PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
d9dac8cd 1318 PerlIO_list_t *layers, IV n, IV max)
14a5cf38 1319{
14a5cf38
JH
1320 int code = 0;
1321 while (n < max) {
8772537c 1322 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
14a5cf38
JH
1323 if (tab) {
1324 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1325 code = -1;
1326 break;
1327 }
1328 }
1329 n++;
1330 }
1331 return code;
e3f3bf95
NIS
1332}
1333
1334int
ac27b0f5
NIS
1335PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1336{
14a5cf38 1337 int code = 0;
53f1b6d2 1338 if (f && names) {
8772537c 1339 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
14a5cf38
JH
1340 code = PerlIO_parse_layers(aTHX_ layers, names);
1341 if (code == 0) {
d9dac8cd 1342 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
14a5cf38 1343 }
3a1ee7e8 1344 PerlIO_list_free(aTHX_ layers);
ac27b0f5 1345 }
14a5cf38 1346 return code;
ac27b0f5
NIS
1347}
1348
f3862f8b 1349
60382766 1350/*--------------------------------------------------------------------------------------*/
14a5cf38 1351/*
71200d45 1352 * Given the abstraction above the public API functions
14a5cf38 1353 */
60382766
NIS
1354
1355int
f5b9d040 1356PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 1357{
68b5363f
PD
1358 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1359 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1360 iotype, mode, (names) ? names : "(Null)");
1361
03c0554d
NIS
1362 if (names) {
1363 /* Do not flush etc. if (e.g.) switching encodings.
1364 if a pushed layer knows it needs to flush lower layers
1365 (for example :unix which is never going to call them)
1366 it can do the flush when it is pushed.
1367 */
1368 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1369 }
1370 else {
86e05cf2 1371 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
35990314 1372#ifdef PERLIO_USING_CRLF
03c0554d
NIS
1373 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1374 O_BINARY so we can look for it in mode.
1375 */
1376 if (!(mode & O_BINARY)) {
1377 /* Text mode */
86e05cf2
NIS
1378 /* FIXME?: Looking down the layer stack seems wrong,
1379 but is a way of reaching past (say) an encoding layer
1380 to flip CRLF-ness of the layer(s) below
1381 */
03c0554d
NIS
1382 while (*f) {
1383 /* Perhaps we should turn on bottom-most aware layer
1384 e.g. Ilya's idea that UNIX TTY could serve
1385 */
1386 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1387 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1388 /* Not in text mode - flush any pending stuff and flip it */
1389 PerlIO_flush(f);
1390 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1391 }
1392 /* Only need to turn it on in one layer so we are done */
1393 return TRUE;
ed53a2bb 1394 }
03c0554d 1395 f = PerlIONext(f);
14a5cf38 1396 }
03c0554d
NIS
1397 /* Not finding a CRLF aware layer presumably means we are binary
1398 which is not what was requested - so we failed
1399 We _could_ push :crlf layer but so could caller
1400 */
1401 return FALSE;
14a5cf38 1402 }
6ce75a77 1403#endif
86e05cf2
NIS
1404 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1405 So code that used to be here is now in PerlIORaw_pushed().
03c0554d 1406 */
a0714e2c 1407 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
14a5cf38 1408 }
f5b9d040
NIS
1409}
1410
f5b9d040 1411int
e87a358a 1412PerlIO__close(pTHX_ PerlIO *f)
f5b9d040 1413{
37725cdc 1414 if (PerlIOValid(f)) {
46c461b5 1415 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
37725cdc
NIS
1416 if (tab && tab->Close)
1417 return (*tab->Close)(aTHX_ f);
1418 else
1419 return PerlIOBase_close(aTHX_ f);
1420 }
14a5cf38 1421 else {
93189314 1422 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1423 return -1;
1424 }
76ced9ad
NIS
1425}
1426
b931b1d9 1427int
e87a358a 1428Perl_PerlIO_close(pTHX_ PerlIO *f)
b931b1d9 1429{
de009b76 1430 const int code = PerlIO__close(aTHX_ f);
37725cdc
NIS
1431 while (PerlIOValid(f)) {
1432 PerlIO_pop(aTHX_ f);
f6c77cf1 1433 }
14a5cf38 1434 return code;
b931b1d9
NIS
1435}
1436
b931b1d9 1437int
e87a358a 1438Perl_PerlIO_fileno(pTHX_ PerlIO *f)
b931b1d9 1439{
97aff369 1440 dVAR;
b32dd47e 1441 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
b931b1d9
NIS
1442}
1443
1141d9f8 1444
fcf2db38 1445static PerlIO_funcs *
2edd7e44
NIS
1446PerlIO_layer_from_ref(pTHX_ SV *sv)
1447{
97aff369 1448 dVAR;
14a5cf38 1449 /*
71200d45 1450 * For any scalar type load the handler which is bundled with perl
14a5cf38 1451 */
75208dda
RGS
1452 if (SvTYPE(sv) < SVt_PVAV) {
1453 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1454 /* This isn't supposed to happen, since PerlIO::scalar is core,
1455 * but could happen anyway in smaller installs or with PAR */
a2a5de95
NC
1456 if (!f)
1457 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
75208dda
RGS
1458 return f;
1459 }
14a5cf38
JH
1460
1461 /*
71200d45 1462 * For other types allow if layer is known but don't try and load it
14a5cf38
JH
1463 */
1464 switch (SvTYPE(sv)) {
1465 case SVt_PVAV:
6a245ed1 1466 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
14a5cf38 1467 case SVt_PVHV:
6a245ed1 1468 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
14a5cf38 1469 case SVt_PVCV:
6a245ed1 1470 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
14a5cf38 1471 case SVt_PVGV:
6a245ed1 1472 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
42d0e0b7
AL
1473 default:
1474 return NULL;
14a5cf38 1475 }
2edd7e44
NIS
1476}
1477
fcf2db38 1478PerlIO_list_t *
14a5cf38
JH
1479PerlIO_resolve_layers(pTHX_ const char *layers,
1480 const char *mode, int narg, SV **args)
1481{
97aff369 1482 dVAR;
14a5cf38
JH
1483 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1484 int incdef = 1;
a1ea730d 1485 if (!PL_perlio)
14a5cf38
JH
1486 PerlIO_stdstreams(aTHX);
1487 if (narg) {
dcda55fc 1488 SV * const arg = *args;
14a5cf38 1489 /*
71200d45
NIS
1490 * If it is a reference but not an object see if we have a handler
1491 * for it
14a5cf38
JH
1492 */
1493 if (SvROK(arg) && !sv_isobject(arg)) {
46c461b5 1494 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1495 if (handler) {
3a1ee7e8
NIS
1496 def = PerlIO_list_alloc(aTHX);
1497 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH
1498 incdef = 0;
1499 }
1500 /*
e934609f 1501 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1502 * something sensible else we will just stringfy and open
71200d45 1503 * resulting string.
14a5cf38
JH
1504 */
1505 }
1506 }
9fe371da 1507 if (!layers || !*layers)
11bcd5da 1508 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1509 if (layers && *layers) {
1510 PerlIO_list_t *av;
1511 if (incdef) {
a951d81d 1512 av = PerlIO_clone_list(aTHX_ def, NULL);
14a5cf38
JH
1513 }
1514 else {
1515 av = def;
1516 }
0cff2cf3
NIS
1517 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1518 return av;
1519 }
1520 else {
1521 PerlIO_list_free(aTHX_ av);
b37c2d43 1522 return NULL;
0cff2cf3 1523 }
14a5cf38
JH
1524 }
1525 else {
1526 if (incdef)
1527 def->refcnt++;
1528 return def;
1529 }
ee518936
NIS
1530}
1531
1532PerlIO *
14a5cf38
JH
1533PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1534 int imode, int perm, PerlIO *f, int narg, SV **args)
1535{
97aff369 1536 dVAR;
14a5cf38
JH
1537 if (!f && narg == 1 && *args == &PL_sv_undef) {
1538 if ((f = PerlIO_tmpfile())) {
9fe371da 1539 if (!layers || !*layers)
11bcd5da 1540 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1541 if (layers && *layers)
1542 PerlIO_apply_layers(aTHX_ f, mode, layers);
1543 }
1544 }
1545 else {
de009b76 1546 PerlIO_list_t *layera;
14a5cf38
JH
1547 IV n;
1548 PerlIO_funcs *tab = NULL;
04892f78 1549 if (PerlIOValid(f)) {
14a5cf38 1550 /*
71200d45
NIS
1551 * This is "reopen" - it is not tested as perl does not use it
1552 * yet
14a5cf38
JH
1553 */
1554 PerlIOl *l = *f;
3a1ee7e8 1555 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1556 while (l) {
a951d81d
BL
1557 SV *arg = NULL;
1558 if (l->tab->Getarg)
1559 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1560 PerlIO_list_push(aTHX_ layera, l->tab,
1561 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1562 SvREFCNT_dec(arg);
14a5cf38
JH
1563 l = *PerlIONext(&l);
1564 }
1565 }
1566 else {
1567 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS
1568 if (!layera) {
1569 return NULL;
1570 }
14a5cf38
JH
1571 }
1572 /*
71200d45 1573 * Start at "top" of layer stack
14a5cf38
JH
1574 */
1575 n = layera->cur - 1;
1576 while (n >= 0) {
46c461b5 1577 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH
1578 if (t && t->Open) {
1579 tab = t;
1580 break;
1581 }
1582 n--;
1583 }
1584 if (tab) {
1585 /*
71200d45 1586 * Found that layer 'n' can do opens - call it
14a5cf38 1587 */
7cf31beb 1588 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1589 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1590 }
14a5cf38 1591 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
355d3743
PD
1592 tab->name, layers ? layers : "(Null)", mode, fd,
1593 imode, perm, (void*)f, narg, (void*)args);
210e727c
JH
1594 if (tab->Open)
1595 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1596 f, narg, args);
1597 else {
1598 SETERRNO(EINVAL, LIB_INVARG);
1599 f = NULL;
1600 }
14a5cf38
JH
1601 if (f) {
1602 if (n + 1 < layera->cur) {
1603 /*
1604 * More layers above the one that we used to open -
71200d45 1605 * apply them now
14a5cf38 1606 */
d9dac8cd
NIS
1607 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1608 /* If pushing layers fails close the file */
1609 PerlIO_close(f);
14a5cf38
JH
1610 f = NULL;
1611 }
1612 }
1613 }
1614 }
3a1ee7e8 1615 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH
1616 }
1617 return f;
ee518936 1618}
b931b1d9
NIS
1619
1620
9e353e3b 1621SSize_t
e87a358a 1622Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1623{
7918f24d
NC
1624 PERL_ARGS_ASSERT_PERLIO_READ;
1625
b32dd47e 1626 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1627}
1628
313ca112 1629SSize_t
e87a358a 1630Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1631{
7918f24d
NC
1632 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1633
b32dd47e 1634 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1635}
1636
9e353e3b 1637SSize_t
e87a358a 1638Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1639{
7918f24d
NC
1640 PERL_ARGS_ASSERT_PERLIO_WRITE;
1641
b32dd47e 1642 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1643}
1644
6f9d8c32 1645int
e87a358a 1646Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1647{
b32dd47e 1648 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW
1649}
1650
9e353e3b 1651Off_t
e87a358a 1652Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1653{
b32dd47e 1654 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW
1655}
1656
6f9d8c32 1657int
e87a358a 1658Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1659{
97aff369 1660 dVAR;
14a5cf38
JH
1661 if (f) {
1662 if (*f) {
de009b76 1663 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH
1664
1665 if (tab && tab->Flush)
f62ce20a 1666 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH
1667 else
1668 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH
1669 }
1670 else {
fe5a182c 1671 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
93189314 1672 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1673 return -1;
1674 }
1675 }
1676 else {
1677 /*
1678 * Is it good API design to do flush-all on NULL, a potentially
1679 * errorneous input? Maybe some magical value (PerlIO*
1680 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1681 * things on fflush(NULL), but should we be bound by their design
71200d45 1682 * decisions? --jhi
14a5cf38 1683 */
a1ea730d 1684 PerlIO **table = &PL_perlio;
14a5cf38
JH
1685 int code = 0;
1686 while ((f = *table)) {
1687 int i;
1688 table = (PerlIO **) (f++);
1689 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1690 if (*f && PerlIO_flush(f) != 0)
1691 code = -1;
1692 f++;
1693 }
1694 }
1695 return code;
1696 }
760ac839
LW
1697}
1698
a9c883f6 1699void
f62ce20a 1700PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1701{
97aff369 1702 dVAR;
a1ea730d 1703 PerlIO **table = &PL_perlio;
14a5cf38
JH
1704 PerlIO *f;
1705 while ((f = *table)) {
1706 int i;
1707 table = (PerlIO **) (f++);
1708 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1709 if (*f
1710 && (PerlIOBase(f)->
1711 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1712 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1713 PerlIO_flush(f);
1714 f++;
1715 }
a9c883f6 1716 }
a9c883f6
NIS
1717}
1718
06da4f11 1719int
e87a358a 1720Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1721{
b32dd47e 1722 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS
1723}
1724
f3862f8b
NIS
1725int
1726PerlIO_isutf8(PerlIO *f)
1727{
1b7a0411
JH
1728 if (PerlIOValid(f))
1729 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1730 else
1731 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1732
1b7a0411 1733 return -1;
f3862f8b
NIS
1734}
1735
6f9d8c32 1736int
e87a358a 1737Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1738{
b32dd47e 1739 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS
1740}
1741
9e353e3b 1742int
e87a358a 1743Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1744{
b32dd47e 1745 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS
1746}
1747
9e353e3b 1748void
e87a358a 1749Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1750{
b32dd47e 1751 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS
1752}
1753
9e353e3b 1754void
e87a358a 1755Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1756{
b32dd47e 1757 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS
1758}
1759
9e353e3b
NIS
1760int
1761PerlIO_has_base(PerlIO *f)
1762{
1b7a0411 1763 if (PerlIOValid(f)) {
46c461b5 1764 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1765
1766 if (tab)
1767 return (tab->Get_base != NULL);
1b7a0411 1768 }
1b7a0411
JH
1769
1770 return 0;
760ac839
LW
1771}
1772
9e353e3b
NIS
1773int
1774PerlIO_fast_gets(PerlIO *f)
760ac839 1775{
d7dfc388
SK
1776 if (PerlIOValid(f)) {
1777 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1778 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411 1779
d7dfc388
SK
1780 if (tab)
1781 return (tab->Set_ptrcnt != NULL);
d7dfc388 1782 }
14a5cf38 1783 }
1b7a0411 1784
14a5cf38 1785 return 0;
9e353e3b
NIS
1786}
1787
9e353e3b
NIS
1788int
1789PerlIO_has_cntptr(PerlIO *f)
1790{
04892f78 1791 if (PerlIOValid(f)) {
46c461b5 1792 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1793
1794 if (tab)
1795 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
14a5cf38 1796 }
1b7a0411 1797
14a5cf38 1798 return 0;
9e353e3b
NIS
1799}
1800
9e353e3b
NIS
1801int
1802PerlIO_canset_cnt(PerlIO *f)
1803{
04892f78 1804 if (PerlIOValid(f)) {
46c461b5 1805 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1806
1807 if (tab)
1808 return (tab->Set_ptrcnt != NULL);
14a5cf38 1809 }
1b7a0411 1810
14a5cf38 1811 return 0;
760ac839
LW
1812}
1813
888911fc 1814STDCHAR *
e87a358a 1815Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1816{
b32dd47e 1817 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS
1818}
1819
9e353e3b 1820int
e87a358a 1821Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1822{
b32dd47e 1823 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS
1824}
1825
9e353e3b 1826STDCHAR *
e87a358a 1827Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1828{
b32dd47e 1829 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS
1830}
1831
05d1247b 1832int
e87a358a 1833Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1834{
b32dd47e 1835 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS
1836}
1837
9e353e3b 1838void
e87a358a 1839Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
9e353e3b 1840{
b32dd47e 1841 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS
1842}
1843
9e353e3b 1844void
e87a358a 1845Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
9e353e3b 1846{
b32dd47e 1847 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS
1848}
1849
4ec2216f 1850
9e353e3b 1851/*--------------------------------------------------------------------------------------*/
14a5cf38 1852/*
71200d45 1853 * utf8 and raw dummy layers
14a5cf38 1854 */
dfebf958 1855
26fb694e 1856IV
2dc2558e 1857PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1858{
96a5add6 1859 PERL_UNUSED_CONTEXT;
8772537c
AL
1860 PERL_UNUSED_ARG(mode);
1861 PERL_UNUSED_ARG(arg);
00f51856 1862 if (PerlIOValid(f)) {
14a5cf38
JH
1863 if (tab->kind & PERLIO_K_UTF8)
1864 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1865 else
1866 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1867 return 0;
1868 }
1869 return -1;
26fb694e
NIS
1870}
1871
27da23d5 1872PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1873 sizeof(PerlIO_funcs),
14a5cf38 1874 "utf8",
2dc2558e 1875 0,
6874a2de 1876 PERLIO_K_DUMMY | PERLIO_K_UTF8,
14a5cf38
JH
1877 PerlIOUtf8_pushed,
1878 NULL,
1879 NULL,
1880 NULL,
1881 NULL,
1882 NULL,
1883 NULL,
1884 NULL,
1885 NULL,
1886 NULL,
1887 NULL,
de009b76
AL
1888 NULL,
1889 NULL,
22569500
NIS
1890 NULL, /* flush */
1891 NULL, /* fill */
14a5cf38
JH
1892 NULL,
1893 NULL,
1894 NULL,
1895 NULL,
22569500
NIS
1896 NULL, /* get_base */
1897 NULL, /* get_bufsiz */
1898 NULL, /* get_ptr */
1899 NULL, /* get_cnt */
1900 NULL, /* set_ptrcnt */
26fb694e
NIS
1901};
1902
27da23d5 1903PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1904 sizeof(PerlIO_funcs),
14a5cf38 1905 "bytes",
2dc2558e 1906 0,
14a5cf38
JH
1907 PERLIO_K_DUMMY,
1908 PerlIOUtf8_pushed,
1909 NULL,
1910 NULL,
1911 NULL,
1912 NULL,
1913 NULL,
1914 NULL,
1915 NULL,
1916 NULL,
1917 NULL,
1918 NULL,
de009b76
AL
1919 NULL,
1920 NULL,
22569500
NIS
1921 NULL, /* flush */
1922 NULL, /* fill */
14a5cf38
JH
1923 NULL,
1924 NULL,
1925 NULL,
1926 NULL,
22569500
NIS
1927 NULL, /* get_base */
1928 NULL, /* get_bufsiz */
1929 NULL, /* get_ptr */
1930 NULL, /* get_cnt */
1931 NULL, /* set_ptrcnt */
dfebf958
NIS
1932};
1933
1934PerlIO *
14a5cf38
JH
1935PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1936 IV n, const char *mode, int fd, int imode, int perm,
1937 PerlIO *old, int narg, SV **args)
dfebf958 1938{
8772537c
AL
1939 PerlIO_funcs * const tab = PerlIO_default_btm();
1940 PERL_UNUSED_ARG(self);
210e727c
JH
1941 if (tab && tab->Open)
1942 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1943 old, narg, args);
1944 SETERRNO(EINVAL, LIB_INVARG);
1945 return NULL;
dfebf958
NIS
1946}
1947
27da23d5 1948PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 1949 sizeof(PerlIO_funcs),
14a5cf38 1950 "raw",
2dc2558e 1951 0,
14a5cf38
JH
1952 PERLIO_K_DUMMY,
1953 PerlIORaw_pushed,
1954 PerlIOBase_popped,
1955 PerlIORaw_open,
1956 NULL,
1957 NULL,
1958 NULL,
1959 NULL,
1960 NULL,
1961 NULL,
1962 NULL,
1963 NULL,
de009b76
AL
1964 NULL,
1965 NULL,
22569500
NIS
1966 NULL, /* flush */
1967 NULL, /* fill */
14a5cf38
JH
1968 NULL,
1969 NULL,
1970 NULL,
1971 NULL,
22569500
NIS
1972 NULL, /* get_base */
1973 NULL, /* get_bufsiz */
1974 NULL, /* get_ptr */
1975 NULL, /* get_cnt */
1976 NULL, /* set_ptrcnt */
dfebf958
NIS
1977};
1978/*--------------------------------------------------------------------------------------*/
1979/*--------------------------------------------------------------------------------------*/
14a5cf38 1980/*
71200d45 1981 * "Methods" of the "base class"
14a5cf38 1982 */
9e353e3b
NIS
1983
1984IV
f62ce20a 1985PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 1986{
04892f78 1987 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS
1988}
1989
f5b9d040 1990char *
81428673 1991PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH
1992{
1993 char *s = buf;
81428673 1994 if (PerlIOValid(f)) {
de009b76 1995 const IV flags = PerlIOBase(f)->flags;
81428673
NIS
1996 if (flags & PERLIO_F_APPEND) {
1997 *s++ = 'a';
1998 if (flags & PERLIO_F_CANREAD) {
1999 *s++ = '+';
2000 }
14a5cf38 2001 }
81428673
NIS
2002 else if (flags & PERLIO_F_CANREAD) {
2003 *s++ = 'r';
2004 if (flags & PERLIO_F_CANWRITE)
2005 *s++ = '+';
2006 }
2007 else if (flags & PERLIO_F_CANWRITE) {
2008 *s++ = 'w';
2009 if (flags & PERLIO_F_CANREAD) {
2010 *s++ = '+';
2011 }
14a5cf38 2012 }
35990314 2013#ifdef PERLIO_USING_CRLF
81428673
NIS
2014 if (!(flags & PERLIO_F_CRLF))
2015 *s++ = 'b';
5f1a76d0 2016#endif
81428673 2017 }
14a5cf38
JH
2018 *s = '\0';
2019 return buf;
f5b9d040
NIS
2020}
2021
81428673 2022
76ced9ad 2023IV
2dc2558e 2024PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 2025{
de009b76 2026 PerlIOl * const l = PerlIOBase(f);
96a5add6 2027 PERL_UNUSED_CONTEXT;
8772537c 2028 PERL_UNUSED_ARG(arg);
de009b76 2029
14a5cf38
JH
2030 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2031 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2032 if (tab->Set_ptrcnt != NULL)
2033 l->flags |= PERLIO_F_FASTGETS;
2034 if (mode) {
3b6c1aba 2035 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2036 mode++;
2037 switch (*mode++) {
2038 case 'r':
2039 l->flags |= PERLIO_F_CANREAD;
2040 break;
2041 case 'a':
2042 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2043 break;
2044 case 'w':
2045 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2046 break;
2047 default:
93189314 2048 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2049 return -1;
2050 }
2051 while (*mode) {
2052 switch (*mode++) {
2053 case '+':
2054 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2055 break;
2056 case 'b':
2057 l->flags &= ~PERLIO_F_CRLF;
2058 break;
2059 case 't':
2060 l->flags |= PERLIO_F_CRLF;
2061 break;
2062 default:
93189314 2063 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2064 return -1;
2065 }
2066 }
2067 }
2068 else {
2069 if (l->next) {
2070 l->flags |= l->next->flags &
2071 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2072 PERLIO_F_APPEND);
2073 }
2074 }
5e2ab84b 2075#if 0
14a5cf38 2076 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
6c9570dc 2077 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
14a5cf38 2078 l->flags, PerlIO_modestr(f, temp));
5e2ab84b 2079#endif
14a5cf38 2080 return 0;
76ced9ad
NIS
2081}
2082
2083IV
f62ce20a 2084PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2085{
96a5add6 2086 PERL_UNUSED_CONTEXT;
8772537c 2087 PERL_UNUSED_ARG(f);
14a5cf38 2088 return 0;
760ac839
LW
2089}
2090
9e353e3b 2091SSize_t
f62ce20a 2092PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2093{
14a5cf38 2094 /*
71200d45 2095 * Save the position as current head considers it
14a5cf38 2096 */
de009b76 2097 const Off_t old = PerlIO_tell(f);
a0714e2c 2098 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2099 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2100 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS
2101}
2102
f6c77cf1 2103SSize_t
f62ce20a 2104PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2105{
14a5cf38
JH
2106 STDCHAR *buf = (STDCHAR *) vbuf;
2107 if (f) {
263df5f1
JH
2108 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2109 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2110 SETERRNO(EBADF, SS_IVCHAN);
2111 return 0;
2112 }
14a5cf38 2113 while (count > 0) {
93c2c2ec
IZ
2114 get_cnt:
2115 {
14a5cf38
JH
2116 SSize_t avail = PerlIO_get_cnt(f);
2117 SSize_t take = 0;
2118 if (avail > 0)
bb7a0f54 2119 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
14a5cf38
JH
2120 if (take > 0) {
2121 STDCHAR *ptr = PerlIO_get_ptr(f);
2122 Copy(ptr, buf, take, STDCHAR);
2123 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2124 count -= take;
2125 buf += take;
93c2c2ec
IZ
2126 if (avail == 0) /* set_ptrcnt could have reset avail */
2127 goto get_cnt;
14a5cf38
JH
2128 }
2129 if (count > 0 && avail <= 0) {
2130 if (PerlIO_fill(f) != 0)
2131 break;
2132 }
93c2c2ec 2133 }
14a5cf38
JH
2134 }
2135 return (buf - (STDCHAR *) vbuf);
2136 }
f6c77cf1 2137 return 0;
f6c77cf1
NIS
2138}
2139
9e353e3b 2140IV
f62ce20a 2141PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2142{
96a5add6 2143 PERL_UNUSED_CONTEXT;
8772537c 2144 PERL_UNUSED_ARG(f);
14a5cf38 2145 return 0;
9e353e3b
NIS
2146}
2147
2148IV
f62ce20a 2149PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2150{
96a5add6 2151 PERL_UNUSED_CONTEXT;
8772537c 2152 PERL_UNUSED_ARG(f);
14a5cf38 2153 return -1;
06da4f11
NIS
2154}
2155
2156IV
f62ce20a 2157PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2158{
37725cdc
NIS
2159 IV code = -1;
2160 if (PerlIOValid(f)) {
2161 PerlIO *n = PerlIONext(f);
2162 code = PerlIO_flush(f);
2163 PerlIOBase(f)->flags &=
2164 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2165 while (PerlIOValid(n)) {
de009b76 2166 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS
2167 if (tab && tab->Close) {
2168 if ((*tab->Close)(aTHX_ n) != 0)
2169 code = -1;
2170 break;
2171 }
2172 else {
2173 PerlIOBase(n)->flags &=
2174 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2175 }
2176 n = PerlIONext(n);
2177 }
2178 }
2179 else {
2180 SETERRNO(EBADF, SS_IVCHAN);
2181 }
14a5cf38 2182 return code;
9e353e3b
NIS
2183}
2184
2185IV
f62ce20a 2186PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2187{
96a5add6 2188 PERL_UNUSED_CONTEXT;
04892f78 2189 if (PerlIOValid(f)) {
14a5cf38
JH
2190 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2191 }
2192 return 1;
9e353e3b
NIS
2193}
2194
2195IV
f62ce20a 2196PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2197{
96a5add6 2198 PERL_UNUSED_CONTEXT;
04892f78 2199 if (PerlIOValid(f)) {
14a5cf38
JH
2200 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2201 }
2202 return 1;
9e353e3b
NIS
2203}
2204
2205void
f62ce20a 2206PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2207{
04892f78 2208 if (PerlIOValid(f)) {
dcda55fc 2209 PerlIO * const n = PerlIONext(f);
14a5cf38 2210 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2211 if (PerlIOValid(n))
14a5cf38
JH
2212 PerlIO_clearerr(n);
2213 }
9e353e3b
NIS
2214}
2215
2216void
f62ce20a 2217PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2218{
96a5add6 2219 PERL_UNUSED_CONTEXT;
04892f78 2220 if (PerlIOValid(f)) {
14a5cf38
JH
2221 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2222 }
9e353e3b
NIS
2223}
2224
93a8090d
NIS
2225SV *
2226PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2227{
2228 if (!arg)
a0714e2c 2229 return NULL;
93a8090d
NIS
2230#ifdef sv_dup
2231 if (param) {
a951d81d
BL
2232 arg = sv_dup(arg, param);
2233 SvREFCNT_inc_simple_void_NN(arg);
2234 return arg;
93a8090d
NIS
2235 }
2236 else {
2237 return newSVsv(arg);
2238 }
2239#else
1b6737cc 2240 PERL_UNUSED_ARG(param);
93a8090d
NIS
2241 return newSVsv(arg);
2242#endif
2243}
2244
2245PerlIO *
ecdeb87c 2246PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2247{
1b6737cc 2248 PerlIO * const nexto = PerlIONext(o);
04892f78 2249 if (PerlIOValid(nexto)) {
de009b76 2250 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS
2251 if (tab && tab->Dup)
2252 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2253 else
2254 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS
2255 }
2256 if (f) {
dcda55fc 2257 PerlIO_funcs * const self = PerlIOBase(o)->tab;
a951d81d 2258 SV *arg = NULL;
93a8090d 2259 char buf[8];
fe5a182c
JH
2260 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2261 self->name, (void*)f, (void*)o, (void*)param);
210e727c
JH
2262 if (self->Getarg)
2263 arg = (*self->Getarg)(aTHX_ o, param, flags);
93a8090d 2264 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
f0720f70
RGS
2265 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2266 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
ef8d46e8 2267 SvREFCNT_dec(arg);
93a8090d
NIS
2268 }
2269 return f;
2270}
2271
27da23d5 2272/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d 2273
8b84d7dd 2274/* Must be called with PL_perlio_mutex locked. */
22c96fc1
NC
2275static void
2276S_more_refcounted_fds(pTHX_ const int new_fd) {
7a89be66 2277 dVAR;
22c96fc1 2278 const int old_max = PL_perlio_fd_refcnt_size;
f4ae5be6 2279 const int new_max = 16 + (new_fd & ~15);
22c96fc1
NC
2280 int *new_array;
2281
2282 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2283 old_max, new_fd, new_max);
2284
2285 if (new_fd < old_max) {
2286 return;
2287 }
2288
f4ae5be6
NC
2289 assert (new_max > new_fd);
2290
eae082a0
JH
2291 /* Use plain realloc() since we need this memory to be really
2292 * global and visible to all the interpreters and/or threads. */
2293 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
22c96fc1
NC
2294
2295 if (!new_array) {
8b84d7dd 2296#ifdef USE_ITHREADS
6cb8cb21 2297 MUTEX_UNLOCK(&PL_perlio_mutex);
22c96fc1
NC
2298#endif
2299 /* Can't use PerlIO to write as it allocates memory */
2300 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2301 PL_no_mem, strlen(PL_no_mem));
2302 my_exit(1);
2303 }
2304
2305 PL_perlio_fd_refcnt_size = new_max;
2306 PL_perlio_fd_refcnt = new_array;
2307
95b63a38
JH
2308 PerlIO_debug("Zeroing %p, %d\n",
2309 (void*)(new_array + old_max),
2310 new_max - old_max);
22c96fc1
NC
2311
2312 Zero(new_array + old_max, new_max - old_max, int);
2313}
2314
2315
93a8090d
NIS
2316void
2317PerlIO_init(pTHX)
2318{
8b84d7dd 2319 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
96a5add6 2320 PERL_UNUSED_CONTEXT;
93a8090d
NIS
2321}
2322
168d5872
NIS
2323void
2324PerlIOUnix_refcnt_inc(int fd)
2325{
27da23d5 2326 dTHX;
22c96fc1 2327 if (fd >= 0) {
97aff369 2328 dVAR;
22c96fc1 2329
8b84d7dd 2330#ifdef USE_ITHREADS
6cb8cb21 2331 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2332#endif
22c96fc1
NC
2333 if (fd >= PL_perlio_fd_refcnt_size)
2334 S_more_refcounted_fds(aTHX_ fd);
2335
27da23d5 2336 PL_perlio_fd_refcnt[fd]++;
8b84d7dd
RGS
2337 if (PL_perlio_fd_refcnt[fd] <= 0) {
2338 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2339 fd, PL_perlio_fd_refcnt[fd]);
2340 }
2341 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2342 fd, PL_perlio_fd_refcnt[fd]);
22c96fc1 2343
8b84d7dd 2344#ifdef USE_ITHREADS
6cb8cb21 2345 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2346#endif
8b84d7dd
RGS
2347 } else {
2348 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
168d5872
NIS
2349 }
2350}
2351
168d5872
NIS
2352int
2353PerlIOUnix_refcnt_dec(int fd)
2354{
27da23d5 2355 dTHX;
168d5872 2356 int cnt = 0;
22c96fc1 2357 if (fd >= 0) {
97aff369 2358 dVAR;
8b84d7dd 2359#ifdef USE_ITHREADS
6cb8cb21 2360 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2361#endif
8b84d7dd
RGS
2362 if (fd >= PL_perlio_fd_refcnt_size) {
2363 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2364 fd, PL_perlio_fd_refcnt_size);
2365 }
2366 if (PL_perlio_fd_refcnt[fd] <= 0) {
2367 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2368 fd, PL_perlio_fd_refcnt[fd]);
2369 }
27da23d5 2370 cnt = --PL_perlio_fd_refcnt[fd];
8b84d7dd
RGS
2371 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2372#ifdef USE_ITHREADS
6cb8cb21 2373 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2374#endif
8b84d7dd
RGS
2375 } else {
2376 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
168d5872
NIS
2377 }
2378 return cnt;
2379}
2380
694c95cf
JH
2381void
2382PerlIO_cleanup(pTHX)
2383{
97aff369 2384 dVAR;
694c95cf
JH
2385 int i;
2386#ifdef USE_ITHREADS
a25429c6 2387 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
9f4bd222
NIS
2388#else
2389 PerlIO_debug("Cleanup layers\n");
694c95cf 2390#endif
e47547a8 2391
694c95cf
JH
2392 /* Raise STDIN..STDERR refcount so we don't close them */
2393 for (i=0; i < 3; i++)
2394 PerlIOUnix_refcnt_inc(i);
2395 PerlIO_cleantable(aTHX_ &PL_perlio);
2396 /* Restore STDIN..STDERR refcount */
2397 for (i=0; i < 3; i++)
2398 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS
2399
2400 if (PL_known_layers) {
2401 PerlIO_list_free(aTHX_ PL_known_layers);
2402 PL_known_layers = NULL;
2403 }
27da23d5 2404 if (PL_def_layerlist) {
9f4bd222
NIS
2405 PerlIO_list_free(aTHX_ PL_def_layerlist);
2406 PL_def_layerlist = NULL;
2407 }
6cb8cb21
RGS
2408}
2409
0934c9d9 2410void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
6cb8cb21 2411{
53d44271 2412 dVAR;
4f3da17a
DM
2413#if 0
2414/* XXX we can't rely on an interpreter being present at this late stage,
2415 XXX so we can't use a function like PerlLIO_write that relies on one
2416 being present (at least in win32) :-(.
2417 Disable for now.
2418*/
6cb8cb21
RGS
2419#ifdef DEBUGGING
2420 {
2421 /* By now all filehandles should have been closed, so any
2422 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2423 * errors. */
77db880c
JH
2424#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2425#define PERLIO_TEARDOWN_MESSAGE_FD 2
2426 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
6cb8cb21
RGS
2427 int i;
2428 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
77db880c
JH
2429 if (PL_perlio_fd_refcnt[i]) {
2430 const STRLEN len =
2431 my_snprintf(buf, sizeof(buf),
2432 "PerlIO_teardown: fd %d refcnt=%d\n",
2433 i, PL_perlio_fd_refcnt[i]);
2434 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2435 }
6cb8cb21
RGS
2436 }
2437 }
2438#endif
4f3da17a 2439#endif
eae082a0
JH
2440 /* Not bothering with PL_perlio_mutex since by now
2441 * all the interpreters are gone. */
1cd82952
RGS
2442 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2443 && PL_perlio_fd_refcnt) {
eae082a0 2444 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO
2445 PL_perlio_fd_refcnt = NULL;
2446 PL_perlio_fd_refcnt_size = 0;
1cd82952 2447 }
694c95cf
JH
2448}
2449
9e353e3b 2450/*--------------------------------------------------------------------------------------*/
14a5cf38 2451/*
71200d45 2452 * Bottom-most level for UNIX-like case
14a5cf38 2453 */
9e353e3b 2454
14a5cf38 2455typedef struct {
22569500
NIS
2456 struct _PerlIO base; /* The generic part */
2457 int fd; /* UNIX like file descriptor */
2458 int oflags; /* open/fcntl flags */
9e353e3b
NIS
2459} PerlIOUnix;
2460
6f9d8c32 2461int
9e353e3b 2462PerlIOUnix_oflags(const char *mode)
760ac839 2463{
14a5cf38 2464 int oflags = -1;
3b6c1aba 2465 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH
2466 mode++;
2467 switch (*mode) {
2468 case 'r':
2469 oflags = O_RDONLY;
2470 if (*++mode == '+') {
2471 oflags = O_RDWR;
2472 mode++;
2473 }
2474 break;
2475
2476 case 'w':
2477 oflags = O_CREAT | O_TRUNC;
2478 if (*++mode == '+') {
2479 oflags |= O_RDWR;
2480 mode++;
2481 }
2482 else
2483 oflags |= O_WRONLY;
2484 break;
2485
2486 case 'a':
2487 oflags = O_CREAT | O_APPEND;
2488 if (*++mode == '+') {
2489 oflags |= O_RDWR;
2490 mode++;
2491 }
2492 else
2493 oflags |= O_WRONLY;
2494 break;
2495 }
2496 if (*mode == 'b') {
2497 oflags |= O_BINARY;
2498 oflags &= ~O_TEXT;
2499 mode++;
2500 }
2501 else if (*mode == 't') {
2502 oflags |= O_TEXT;
2503 oflags &= ~O_BINARY;
2504 mode++;
2505 }
2506 /*
71200d45 2507 * Always open in binary mode
14a5cf38
JH
2508 */
2509 oflags |= O_BINARY;
2510 if (*mode || oflags == -1) {
93189314 2511 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2512 oflags = -1;
2513 }
2514 return oflags;
9e353e3b
NIS
2515}
2516
2517IV
f62ce20a 2518PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2519{
96a5add6 2520 PERL_UNUSED_CONTEXT;
14a5cf38 2521 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS
2522}
2523
aa063c35
NIS
2524static void
2525PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2526{
de009b76 2527 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2528#if defined(WIN32)
aa063c35
NIS
2529 Stat_t st;
2530 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2531 if (!S_ISREG(st.st_mode)) {
aa063c35 2532 PerlIO_debug("%d is not regular file\n",fd);
6caa5a9c
NIS
2533 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2534 }
aa063c35
NIS
2535 else {
2536 PerlIO_debug("%d _is_ a regular file\n",fd);
2537 }
6caa5a9c
NIS
2538 }
2539#endif
aa063c35
NIS
2540 s->fd = fd;
2541 s->oflags = imode;
2542 PerlIOUnix_refcnt_inc(fd);
96a5add6 2543 PERL_UNUSED_CONTEXT;
aa063c35
NIS
2544}
2545
2546IV
2547PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2548{
2549 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2550 if (*PerlIONext(f)) {
4b069b44 2551 /* We never call down so do any pending stuff now */
03c0554d 2552 PerlIO_flush(PerlIONext(f));
14a5cf38 2553 /*
71200d45 2554 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2555 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2556 * Should the value on NULL mode be 0 or -1?
14a5cf38 2557 */
acbd16bf 2558 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2559 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH
2560 }
2561 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2562
14a5cf38 2563 return code;
4b803d04
NIS
2564}
2565
c2fcde81
JH
2566IV
2567PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2568{
de009b76 2569 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2570 Off_t new_loc;
96a5add6 2571 PERL_UNUSED_CONTEXT;
c2fcde81
JH
2572 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2573#ifdef ESPIPE
2574 SETERRNO(ESPIPE, LIB_INVARG);
2575#else
2576 SETERRNO(EINVAL, LIB_INVARG);
2577#endif
2578 return -1;
2579 }
0723351e
NC
2580 new_loc = PerlLIO_lseek(fd, offset, whence);
2581 if (new_loc == (Off_t) - 1)
dcda55fc 2582 return -1;
c2fcde81
JH
2583 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2584 return 0;
2585}
2586
9e353e3b 2587PerlIO *
14a5cf38
JH
2588PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2589 IV n, const char *mode, int fd, int imode,
2590 int perm, PerlIO *f, int narg, SV **args)
2591{
d9dac8cd 2592 if (PerlIOValid(f)) {
14a5cf38 2593 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2594 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH
2595 }
2596 if (narg > 0) {
3b6c1aba 2597 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH
2598 mode++;
2599 else {
2600 imode = PerlIOUnix_oflags(mode);
2601 perm = 0666;
2602 }
2603 if (imode != -1) {
e62f0680 2604 const char *path = SvPV_nolen_const(*args);
14a5cf38
JH
2605 fd = PerlLIO_open3(path, imode, perm);
2606 }
2607 }
2608 if (fd >= 0) {
3b6c1aba 2609 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2610 mode++;
2611 if (!f) {
2612 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS
2613 }
2614 if (!PerlIOValid(f)) {
a33cf58c
NIS
2615 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2616 return NULL;
2617 }
d9dac8cd 2618 }
aa063c35 2619 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2620 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH
2621 if (*mode == IoTYPE_APPEND)
2622 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH
2623 return f;
2624 }
2625 else {
2626 if (f) {
6f207bd3 2627 NOOP;
14a5cf38 2628 /*
71200d45 2629 * FIXME: pop layers ???
14a5cf38
JH
2630 */
2631 }
2632 return NULL;
2633 }
9e353e3b
NIS
2634}
2635
71200d45 2636PerlIO *
ecdeb87c 2637PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2638{
dcda55fc 2639 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2640 int fd = os->fd;
ecdeb87c
NIS
2641 if (flags & PERLIO_DUP_FD) {
2642 fd = PerlLIO_dup(fd);
2643 }
22c96fc1 2644 if (fd >= 0) {
ecdeb87c 2645 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS
2646 if (f) {
2647 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2648 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS
2649 return f;
2650 }
71200d45
NIS
2651 }
2652 return NULL;
2653}
2654
2655
9e353e3b 2656SSize_t
f62ce20a 2657PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2658{
97aff369 2659 dVAR;
de009b76 2660 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2661#ifdef PERLIO_STD_SPECIAL
2662 if (fd == 0)
2663 return PERLIO_STD_IN(fd, vbuf, count);
2664#endif
81428673 2665 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2666 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2667 return 0;
1fd8f4ce 2668 }
14a5cf38 2669 while (1) {
b464bac0 2670 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2671 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2672 if (len < 0) {
2673 if (errno != EAGAIN) {
2674 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2675 }
2676 }
2677 else if (len == 0 && count != 0) {
14a5cf38 2678 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS
2679 SETERRNO(0,0);
2680 }
14a5cf38
JH
2681 return len;
2682 }
2683 PERL_ASYNC_CHECK();
2684 }
b464bac0 2685 /*NOTREACHED*/
9e353e3b
NIS
2686}
2687
2688SSize_t
f62ce20a 2689PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2690{
97aff369 2691 dVAR;
de009b76 2692 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2693#ifdef PERLIO_STD_SPECIAL
2694 if (fd == 1 || fd == 2)
2695 return PERLIO_STD_OUT(fd, vbuf, count);
2696#endif
14a5cf38 2697 while (1) {
de009b76 2698 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2699 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2700 if (len < 0) {
2701 if (errno != EAGAIN) {
2702 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2703 }
2704 }
14a5cf38
JH
2705 return len;
2706 }
2707 PERL_ASYNC_CHECK();
06da4f11 2708 }
1b6737cc 2709 /*NOTREACHED*/
9e353e3b
NIS
2710}
2711
9e353e3b 2712Off_t
f62ce20a 2713PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2714{
96a5add6
AL
2715 PERL_UNUSED_CONTEXT;
2716
14a5cf38 2717 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2718}
2719
2556f95e
GF
2720
2721IV
2376d97d 2722PerlIOUnix_close(pTHX_ PerlIO *f)
2556f95e 2723{
97aff369 2724 dVAR;
de009b76 2725 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2726 int code = 0;
168d5872
NIS
2727 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2728 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2729 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2730 return 0;
22569500 2731 }
93a8090d
NIS
2732 }
2733 else {
93189314 2734 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2735 return -1;
2736 }
14a5cf38
JH
2737 while (PerlLIO_close(fd) != 0) {
2738 if (errno != EINTR) {
2739 code = -1;
2740 break;
2741 }
2742 PERL_ASYNC_CHECK();
2743 }
2744 if (code == 0) {
2745 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2746 }
2747 return code;
9e353e3b
NIS
2748}
2749
27da23d5 2750PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2751 sizeof(PerlIO_funcs),
14a5cf38
JH
2752 "unix",
2753 sizeof(PerlIOUnix),
2754 PERLIO_K_RAW,
2755 PerlIOUnix_pushed,
2376d97d 2756 PerlIOBase_popped,
14a5cf38 2757 PerlIOUnix_open,
86e05cf2 2758 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2759 NULL,
2760 PerlIOUnix_fileno,
71200d45 2761 PerlIOUnix_dup,
14a5cf38
JH
2762 PerlIOUnix_read,
2763 PerlIOBase_unread,
2764 PerlIOUnix_write,
2765 PerlIOUnix_seek,
2766 PerlIOUnix_tell,
2767 PerlIOUnix_close,
22569500
NIS
2768 PerlIOBase_noop_ok, /* flush */
2769 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2770 PerlIOBase_eof,
2771 PerlIOBase_error,
2772 PerlIOBase_clearerr,
2773 PerlIOBase_setlinebuf,
22569500
NIS
2774 NULL, /* get_base */
2775 NULL, /* get_bufsiz */
2776 NULL, /* get_ptr */
2777 NULL, /* get_cnt */
2778 NULL, /* set_ptrcnt */
9e353e3b
NIS
2779};
2780
2781/*--------------------------------------------------------------------------------------*/
14a5cf38 2782/*
71200d45 2783 * stdio as a layer
14a5cf38 2784 */
9e353e3b 2785
313e59c8
NIS
2786#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2787/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2788 broken by the last second glibc 2.3 fix
2789 */
2790#define STDIO_BUFFER_WRITABLE
2791#endif
2792
2793
14a5cf38
JH
2794typedef struct {
2795 struct _PerlIO base;
22569500 2796 FILE *stdio; /* The stream */
9e353e3b
NIS
2797} PerlIOStdio;
2798
2799IV
f62ce20a 2800PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2801{
96a5add6
AL
2802 PERL_UNUSED_CONTEXT;
2803
c4420975
AL
2804 if (PerlIOValid(f)) {
2805 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2806 if (s)
2807 return PerlSIO_fileno(s);
439ba545
NIS
2808 }
2809 errno = EBADF;
2810 return -1;
9e353e3b
NIS
2811}
2812
766a733e 2813char *
14a5cf38
JH
2814PerlIOStdio_mode(const char *mode, char *tmode)
2815{
de009b76 2816 char * const ret = tmode;
a0625d38
SR
2817 if (mode) {
2818 while (*mode) {
2819 *tmode++ = *mode++;
2820 }
14a5cf38 2821 }
95005ad8 2822#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2823 *tmode++ = 'b';
2824#endif
14a5cf38
JH
2825 *tmode = '\0';
2826 return ret;
2827}
2828
4b803d04 2829IV
2dc2558e 2830PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2831{
1fd8f4ce
NIS
2832 PerlIO *n;
2833 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2834 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS
2835 if (toptab == tab) {
2836 /* Top is already stdio - pop self (duplicate) and use original */
2837 PerlIO_pop(aTHX_ f);
2838 return 0;
2839 } else {
de009b76 2840 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2841 char tmode[8];
2842 FILE *stdio;
81428673 2843 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
2844 mode = PerlIOStdio_mode(mode, tmode)))) {
2845 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2846 /* We never call down so do any pending stuff now */
2847 PerlIO_flush(PerlIONext(f));
81428673 2848 }
1fd8f4ce
NIS
2849 else {
2850 return -1;
2851 }
2852 }
14a5cf38 2853 }
2dc2558e 2854 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
2855}
2856
22569500 2857
9e353e3b 2858PerlIO *
4b069b44 2859PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2860{
14a5cf38
JH
2861 dTHX;
2862 PerlIO *f = NULL;
2863 if (stdio) {
22569500 2864 PerlIOStdio *s;
4b069b44
NIS
2865 if (!mode || !*mode) {
2866 /* We need to probe to see how we can open the stream
2867 so start with read/write and then try write and read
2868 we dup() so that we can fclose without loosing the fd.
2869
2870 Note that the errno value set by a failing fdopen
2871 varies between stdio implementations.
2872 */
de009b76 2873 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 2874 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2875 if (!f2) {
a33cf58c 2876 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
2877 }
2878 if (!f2) {
a33cf58c 2879 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
2880 }
2881 if (!f2) {
2882 /* Don't seem to be able to open */
2883 PerlLIO_close(fd);
2884 return f;
2885 }
2886 fclose(f2);
22569500 2887 }
a0714e2c 2888 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS
2889 s = PerlIOSelf(f, PerlIOStdio);
2890 s->stdio = stdio;
c586124f 2891 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 2892 }
14a5cf38
JH
2893 }
2894 return f;
9e353e3b
NIS
2895}
2896
2897PerlIO *
14a5cf38
JH
2898PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2899 IV n, const char *mode, int fd, int imode,
2900 int perm, PerlIO *f, int narg, SV **args)
2901{
2902 char tmode[8];
d9dac8cd 2903 if (PerlIOValid(f)) {
dcda55fc
AL
2904 const char * const path = SvPV_nolen_const(*args);
2905 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS
2906 FILE *stdio;
2907 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2908 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH
2909 s->stdio);
2910 if (!s->stdio)
2911 return NULL;
2912 s->stdio = stdio;
1751d015 2913 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
2914 return f;
2915 }
2916 else {
2917 if (narg > 0) {
dcda55fc 2918 const char * const path = SvPV_nolen_const(*args);
3b6c1aba 2919 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
2920 mode++;
2921 fd = PerlLIO_open3(path, imode, perm);
2922 }
2923 else {
95005ad8
GH
2924 FILE *stdio;
2925 bool appended = FALSE;
2926#ifdef __CYGWIN__
2927 /* Cygwin wants its 'b' early. */
2928 appended = TRUE;
2929 mode = PerlIOStdio_mode(mode, tmode);
2930#endif
2931 stdio = PerlSIO_fopen(path, mode);
6f0313ac 2932 if (stdio) {
6f0313ac
JH
2933 if (!f) {
2934 f = PerlIO_allocate(aTHX);
2935 }
95005ad8
GH
2936 if (!appended)
2937 mode = PerlIOStdio_mode(mode, tmode);
2938 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2939 if (f) {
0f0f9e2b
JH
2940 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2941 PerlIOUnix_refcnt_inc(fileno(stdio));
2942 } else {
2943 PerlSIO_fclose(stdio);
6f0313ac
JH
2944 }
2945 return f;
2946 }
2947 else {
2948 return NULL;
2949 }
14a5cf38
JH
2950 }
2951 }
2952 if (fd >= 0) {
2953 FILE *stdio = NULL;
2954 int init = 0;
3b6c1aba 2955 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
2956 init = 1;
2957 mode++;
2958 }
2959 if (init) {
2960 switch (fd) {
2961 case 0:
2962 stdio = PerlSIO_stdin;
2963 break;
2964 case 1:
2965 stdio = PerlSIO_stdout;
2966 break;
2967 case 2:
2968 stdio = PerlSIO_stderr;
2969 break;
2970 }
2971 }
2972 else {
2973 stdio = PerlSIO_fdopen(fd, mode =
2974 PerlIOStdio_mode(mode, tmode));
2975 }
2976 if (stdio) {
d9dac8cd
NIS
2977 if (!f) {
2978 f = PerlIO_allocate(aTHX);
2979 }
a33cf58c 2980 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba
JH
2981 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2982 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 2983 }
14a5cf38
JH
2984 return f;
2985 }
2986 }
2987 }
ee518936 2988 return NULL;
9e353e3b
NIS
2989}
2990
1751d015 2991PerlIO *
ecdeb87c 2992PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
2993{
2994 /* This assumes no layers underneath - which is what
2995 happens, but is not how I remember it. NI-S 2001/10/16
2996 */
ecdeb87c 2997 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 2998 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 2999 const int fd = fileno(stdio);
9217ff3f 3000 char mode[8];
ecdeb87c 3001 if (flags & PERLIO_DUP_FD) {
de009b76 3002 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
3003 if (dfd >= 0) {
3004 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3005 goto set_this;
ecdeb87c
NIS
3006 }
3007 else {
6f207bd3 3008 NOOP;
ecdeb87c
NIS
3009 /* FIXME: To avoid messy error recovery if dup fails
3010 re-use the existing stdio as though flag was not set
3011 */
3012 }
3013 }
9217ff3f
NIS
3014 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3015 set_this:
694c95cf 3016 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
40596bc5
SP
3017 if(stdio) {
3018 PerlIOUnix_refcnt_inc(fileno(stdio));
3019 }
1751d015
NIS
3020 }
3021 return f;
3022}
3023
0d7a5398
NIS
3024static int
3025PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3026{
96a5add6
AL
3027 PERL_UNUSED_CONTEXT;
3028
0d7a5398 3029 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3030 * PerlIO_set_fileno() support from Configure
0d7a5398 3031 */
ef8eacb8
AT
3032# if defined(__UCLIBC__)
3033 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3034 f->__filedes = -1;
3035 return 1;
3036# elif defined(__GLIBC__)
0d7a5398 3037 /* There may be a better way for GLIBC:
37725cdc 3038 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
3039 */
3040 f->_fileno = -1;
3041 return 1;
3042# elif defined(__sun__)
f5992bc4 3043 PERL_UNUSED_ARG(f);
cfedb851 3044 return 0;
0d7a5398
NIS
3045# elif defined(__hpux)
3046 f->__fileH = 0xff;
3047 f->__fileL = 0xff;
3048 return 1;
9837d373 3049 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3050 your platform does not have special entry try this one.
9837d373
NIS
3051 [For OSF only have confirmation for Tru64 (alpha)
3052 but assume other OSFs will be similar.]
37725cdc 3053 */
9837d373 3054# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
3055 f->_file = -1;
3056 return 1;
3057# elif defined(__FreeBSD__)
3058 /* There may be a better way on FreeBSD:
37725cdc
NIS
3059 - we could insert a dummy func in the _close function entry
3060 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3061 */
3062 f->_file = -1;
0c49ea6a
SU
3063 return 1;
3064# elif defined(__OpenBSD__)
3065 /* There may be a better way on OpenBSD:
3066 - we could insert a dummy func in the _close function entry
3067 f->_close = (int (*)(void *)) dummy_close;
3068 */
3069 f->_file = -1;
0d7a5398 3070 return 1;
59ad941d
IZ
3071# elif defined(__EMX__)
3072 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3073 f->_handle = -1;
3074 return 1;
0d7a5398
NIS
3075# elif defined(__CYGWIN__)
3076 /* There may be a better way on CYGWIN:
37725cdc
NIS
3077 - we could insert a dummy func in the _close function entry
3078 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3079 */
3080 f->_file = -1;
3081 return 1;
3082# elif defined(WIN32)
3083# if defined(__BORLANDC__)
3084 f->fd = PerlLIO_dup(fileno(f));
b475b3e6
JH
3085# elif defined(UNDER_CE)
3086 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3087 structure at all
3088 */
0d7a5398
NIS
3089# else
3090 f->_file = -1;
3091# endif
3092 return 1;
3093# else
3094#if 0
37725cdc 3095 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3096 (which isn't thread safe) instead
37725cdc 3097 */
0d7a5398
NIS
3098# error "Don't know how to set FILE.fileno on your platform"
3099#endif
8772537c 3100 PERL_UNUSED_ARG(f);
0d7a5398
NIS
3101 return 0;
3102# endif
3103}
3104
1751d015 3105IV
f62ce20a 3106PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3107{
c4420975 3108 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
3109 if (!stdio) {
3110 errno = EBADF;
3111 return -1;
3112 }
9217ff3f 3113 else {
de009b76 3114 const int fd = fileno(stdio);
0d7a5398 3115 int invalidate = 0;
bbfd922f 3116 IV result = 0;
1d791a44 3117 int dupfd = -1;
4ee39169 3118 dSAVEDERRNO;
a2e578da
MHM
3119#ifdef USE_ITHREADS
3120 dVAR;
3121#endif
0d7a5398 3122#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
3123 /* Socks lib overrides close() but stdio isn't linked to
3124 that library (though we are) - so we must call close()
3125 on sockets on stdio's behalf.
3126 */
0d7a5398
NIS
3127 int optval;
3128 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3129 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3130 invalidate = 1;
0d7a5398 3131#endif
d8723f43
NC
3132 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3133 that a subsequent fileno() on it returns -1. Don't want to croak()
3134 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3135 trying to close an already closed handle which somehow it still has
3136 a reference to. (via.xs, I'm looking at you). */
3137 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3138 /* File descriptor still in use */
0d7a5398 3139 invalidate = 1;
d8723f43 3140 }
0d7a5398 3141 if (invalidate) {
6b4ce6c8
AL
3142 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3143 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3144 return 0;
3145 if (stdio == stdout || stdio == stderr)
3146 return PerlIO_flush(f);
37725cdc
NIS
3147 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3148 Use Sarathy's trick from maint-5.6 to invalidate the
3149 fileno slot of the FILE *
3150 */
bbfd922f 3151 result = PerlIO_flush(f);
4ee39169 3152 SAVE_ERRNO;
6b4ce6c8 3153 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
711e8db2 3154 if (!invalidate) {
9bab90c0
NC
3155#ifdef USE_ITHREADS
3156 MUTEX_LOCK(&PL_perlio_mutex);
5ca745d2
NC
3157 /* Right. We need a mutex here because for a brief while we
3158 will have the situation that fd is actually closed. Hence if
3159 a second thread were to get into this block, its dup() would
3160 likely return our fd as its dupfd. (after all, it is closed)
9bab90c0
NC
3161 Then if we get to the dup2() first, we blat the fd back
3162 (messing up its temporary as a side effect) only for it to
3163 then close its dupfd (== our fd) in its close(dupfd) */
3164
3165 /* There is, of course, a race condition, that any other thread
3166 trying to input/output/whatever on this fd will be stuffed
5ca745d2
NC
3167 for the duration of this little manoeuvrer. Perhaps we
3168 should hold an IO mutex for the duration of every IO
3169 operation if we know that invalidate doesn't work on this
3170 platform, but that would suck, and could kill performance.
9bab90c0
NC
3171
3172 Except that correctness trumps speed.
3173 Advice from klortho #11912. */
3174#endif
6b4ce6c8 3175 dupfd = PerlLIO_dup(fd);
711e8db2 3176#ifdef USE_ITHREADS
9bab90c0
NC
3177 if (dupfd < 0) {
3178 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2
NC
3179 /* Oh cXap. This isn't going to go well. Not sure if we can
3180 recover from here, or if closing this particular FILE *
3181 is a good idea now. */
3182 }
3183#endif
3184 }
94ccb807
JH
3185 } else {
3186 SAVE_ERRNO; /* This is here only to silence compiler warnings */
37725cdc 3187 }
0d7a5398 3188 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3189 /* We treat error from stdio as success if we invalidated
3190 errno may NOT be expected EBADF
e8529473
NIS
3191 */
3192 if (invalidate && result != 0) {
4ee39169 3193 RESTORE_ERRNO;
0d7a5398 3194 result = 0;
37725cdc 3195 }
6b4ce6c8
AL
3196#ifdef SOCKS5_VERSION_NAME
3197 /* in SOCKS' case, let close() determine return value */
3198 result = close(fd);
3199#endif
1d791a44 3200 if (dupfd >= 0) {
0d7a5398 3201 PerlLIO_dup2(dupfd,fd);
9bab90c0 3202 PerlLIO_close(dupfd);
711e8db2 3203#ifdef USE_ITHREADS
9bab90c0 3204 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2 3205#endif
9217ff3f
NIS
3206 }
3207 return result;
37725cdc 3208 }
1751d015
NIS
3209}
3210
9e353e3b 3211SSize_t
f62ce20a 3212PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3213{
97aff369 3214 dVAR;
c4420975 3215 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3216 SSize_t got = 0;
4d948241
NIS
3217 for (;;) {
3218 if (count == 1) {
3219 STDCHAR *buf = (STDCHAR *) vbuf;
3220 /*
3221 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3222 * stdio does not do that for fread()
3223 */
de009b76 3224 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3225 if (ch != EOF) {
3226 *buf = ch;
3227 got = 1;
3228 }
14a5cf38 3229 }
4d948241
NIS
3230 else
3231 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3232 if (got == 0 && PerlSIO_ferror(s))
3233 got = -1;
42a7a32f 3234 if (got >= 0 || errno != EINTR)
4d948241
NIS
3235 break;
3236 PERL_ASYNC_CHECK();
42a7a32f 3237 SETERRNO(0,0); /* just in case */
14a5cf38 3238 }
14a5cf38 3239 return got;
9e353e3b
NIS
3240}
3241
3242SSize_t
f62ce20a 3243PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3244{
14a5cf38 3245 SSize_t unread = 0;
c4420975 3246 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3247
313e59c8 3248#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3249 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3250 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3251 STDCHAR *base = PerlIO_get_base(f);
3252 SSize_t cnt = PerlIO_get_cnt(f);
3253 STDCHAR *ptr = PerlIO_get_ptr(f);
3254 SSize_t avail = ptr - base;
3255 if (avail > 0) {
3256 if (avail > count) {
3257 avail = count;
3258 }
3259 ptr -= avail;
3260 Move(buf-avail,ptr,avail,STDCHAR);
3261 count -= avail;
3262 unread += avail;
3263 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3264 if (PerlSIO_feof(s) && unread >= 0)
3265 PerlSIO_clearerr(s);
3266 }
3267 }
313e59c8
NIS
3268 else
3269#endif
3270 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3271 /* We can get pointer to buffer but not its base
3272 Do ungetc() but check chars are ending up in the
3273 buffer
3274 */
3275 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3276 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3277 while (count > 0) {
de009b76 3278 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3279 if (ungetc(ch,s) != ch) {
3280 /* ungetc did not work */
3281 break;
3282 }
3283 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3284 /* Did not change pointer as expected */
3285 fgetc(s); /* get char back again */
3286 break;
3287 }
3288 /* It worked ! */
3289 count--;
3290 unread++;
93679785
NIS
3291 }
3292 }
3293
3294 if (count > 0) {
3295 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3296 }
3297 return unread;
9e353e3b
NIS
3298}
3299
3300SSize_t
f62ce20a 3301PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3302{
97aff369 3303 dVAR;
4d948241
NIS
3304 SSize_t got;
3305 for (;;) {
3306 got = PerlSIO_fwrite(vbuf, 1, count,
3307 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3308 if (got >= 0 || errno != EINTR)
4d948241
NIS
3309 break;
3310 PERL_ASYNC_CHECK();
42a7a32f 3311 SETERRNO(0,0); /* just in case */
4d948241
NIS
3312 }
3313 return got;
9e353e3b
NIS
3314}
3315
94a175e1 3316IV
f62ce20a 3317PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3318{
c4420975 3319 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3320 PERL_UNUSED_CONTEXT;
3321
94a175e1 3322 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3323}
3324
3325Off_t
f62ce20a 3326PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3327{
c4420975 3328 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3329 PERL_UNUSED_CONTEXT;
3330
94a175e1 3331 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3332}
3333
3334IV
f62ce20a 3335PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3336{
c4420975 3337 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3338 PERL_UNUSED_CONTEXT;
3339
14a5cf38
JH
3340 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3341 return PerlSIO_fflush(stdio);
3342 }
3343 else {
6f207bd3 3344 NOOP;
88b61e10 3345#if 0
14a5cf38
JH
3346 /*
3347 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3348 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3349 * design is to do _this_ but not have layer above flush this
71200d45 3350 * layer read-to-read
14a5cf38
JH
3351 */
3352 /*
71200d45 3353 * Not writeable - sync by attempting a seek
14a5cf38 3354 */
4ee39169 3355 dSAVE_ERRNO;
14a5cf38 3356 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3357 RESTORE_ERRNO;
88b61e10 3358#endif
14a5cf38
JH
3359 }
3360 return 0;
9e353e3b
NIS
3361}
3362
3363IV
f62ce20a 3364PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3365{
96a5add6
AL
3366 PERL_UNUSED_CONTEXT;
3367
14a5cf38 3368 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3369}
3370
3371IV
f62ce20a 3372PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3373{
96a5add6
AL
3374 PERL_UNUSED_CONTEXT;
3375
263df5f1 3376 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3377}
3378
3379void
f62ce20a 3380PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3381{
96a5add6
AL
3382 PERL_UNUSED_CONTEXT;
3383
14a5cf38 3384 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3385}
3386
3387void
f62ce20a 3388PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3389{
96a5add6
AL
3390 PERL_UNUSED_CONTEXT;
3391
9e353e3b 3392#ifdef HAS_SETLINEBUF
14a5cf38 3393 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3394#else
bd61b366 3395 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS
3396#endif
3397}
3398
3399#ifdef FILE_base
3400STDCHAR *
f62ce20a 3401PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3402{
c4420975 3403 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3404 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS
3405}
3406
3407Size_t
f62ce20a 3408PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3409{
c4420975 3410 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3411 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS
3412}
3413#endif
3414
3415#ifdef USE_STDIO_PTR
3416STDCHAR *
f62ce20a 3417PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3418{
c4420975 3419 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3420 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS
3421}
3422
3423SSize_t
f62ce20a 3424PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3425{
c4420975 3426 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3427 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS
3428}
3429
3430void
f62ce20a 3431PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3432{
c4420975 3433 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3434 if (ptr != NULL) {
9e353e3b 3435#ifdef STDIO_PTR_LVALUE
d06fc7d4 3436 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
9e353e3b 3437#ifdef STDIO_PTR_LVAL_SETS_CNT
f8a4dbc5 3438 assert(PerlSIO_get_cnt(stdio) == (cnt));
9e353e3b
NIS
3439#endif
3440#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3441 /*
71200d45 3442 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH
3443 */
3444 return;
9e353e3b 3445#endif
22569500 3446#else /* STDIO_PTR_LVALUE */
14a5cf38 3447 PerlProc_abort();
22569500 3448#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH
3449 }
3450 /*
71200d45 3451 * Now (or only) set cnt
14a5cf38 3452 */
9e353e3b 3453#ifdef STDIO_CNT_LVALUE
14a5cf38 3454 PerlSIO_set_cnt(stdio, cnt);
22569500 3455#else /* STDIO_CNT_LVALUE */
9e353e3b 3456#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH
3457 PerlSIO_set_ptr(stdio,
3458 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3459 cnt));
22569500 3460#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3461 PerlProc_abort();
22569500
NIS
3462#endif /* STDIO_PTR_LVAL_SETS_CNT */
3463#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS
3464}
3465
93679785 3466
9e353e3b
NIS
3467#endif
3468
93679785
NIS
3469IV
3470PerlIOStdio_fill(pTHX_ PerlIO *f)
3471{
c4420975 3472 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3473 int c;
96a5add6
AL
3474 PERL_UNUSED_CONTEXT;
3475
93679785
NIS
3476 /*
3477 * fflush()ing read-only streams can cause trouble on some stdio-s
3478 */
3479 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3480 if (PerlSIO_fflush(stdio) != 0)
3481 return EOF;
3482 }
f3be3723
BL
3483 for (;;) {
3484 c = PerlSIO_fgetc(stdio);
3485 if (c != EOF)
3486 break;
3487 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3488 return EOF;
3489 PERL_ASYNC_CHECK();
3490 SETERRNO(0,0);
3491 }
93679785
NIS
3492
3493#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS
3494
3495#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3496 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3497 /* Fake ungetc() to the real buffer in case system's ungetc
3498 goes elsewhere
3499 */
3500 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3501 SSize_t cnt = PerlSIO_get_cnt(stdio);
3502 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3503 if (ptr == base+1) {
3504 *--ptr = (STDCHAR) c;
3505 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3506 if (PerlSIO_feof(stdio))
3507 PerlSIO_clearerr(stdio);
3508 return 0;
3509 }
3510 }
313e59c8
NIS
3511 else
3512#endif
3513 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3514 STDCHAR ch = c;
3515 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3516 return 0;
3517 }
3518 }
93679785
NIS
3519#endif
3520
3521#if defined(VMS)
3522 /* An ungetc()d char is handled separately from the regular
3523 * buffer, so we stuff it in the buffer ourselves.
3524 * Should never get called as should hit code above
3525 */
bad9695d
NIS
3526 *(--((*stdio)->_ptr)) = (unsigned char) c;
3527 (*stdio)->_cnt++;
93679785
NIS
3528#else
3529 /* If buffer snoop scheme above fails fall back to
9f7cd136 3530 using ungetc().
93679785
NIS
3531 */
3532 if (PerlSIO_ungetc(c, stdio) != c)
3533 return EOF;
3534#endif
3535 return 0;
3536}
3537
3538
3539
27da23d5 3540PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3541 sizeof(PerlIO_funcs),
14a5cf38
JH
3542 "stdio",
3543 sizeof(PerlIOStdio),
86e05cf2 3544 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3545 PerlIOStdio_pushed,
2376d97d 3546 PerlIOBase_popped,
14a5cf38 3547 PerlIOStdio_open,