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