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