This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Directly create the SV with Perl_newSVpvf() rather than using
[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
2416void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */
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. */
2424 int i;
2425 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2426 if (PL_perlio_fd_refcnt[i])
2427 PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n",
2428 i, PL_perlio_fd_refcnt[i]);
2429 }
2430 }
2431#endif
eae082a0
JH
2432 /* Not bothering with PL_perlio_mutex since by now
2433 * all the interpreters are gone. */
1cd82952
RGS
2434 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2435 && PL_perlio_fd_refcnt) {
eae082a0 2436 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO
2437 PL_perlio_fd_refcnt = NULL;
2438 PL_perlio_fd_refcnt_size = 0;
1cd82952 2439 }
694c95cf
JH
2440}
2441
9e353e3b 2442/*--------------------------------------------------------------------------------------*/
14a5cf38 2443/*
71200d45 2444 * Bottom-most level for UNIX-like case
14a5cf38 2445 */
9e353e3b 2446
14a5cf38 2447typedef struct {
22569500
NIS
2448 struct _PerlIO base; /* The generic part */
2449 int fd; /* UNIX like file descriptor */
2450 int oflags; /* open/fcntl flags */
9e353e3b
NIS
2451} PerlIOUnix;
2452
6f9d8c32 2453int
9e353e3b 2454PerlIOUnix_oflags(const char *mode)
760ac839 2455{
14a5cf38 2456 int oflags = -1;
3b6c1aba 2457 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH
2458 mode++;
2459 switch (*mode) {
2460 case 'r':
2461 oflags = O_RDONLY;
2462 if (*++mode == '+') {
2463 oflags = O_RDWR;
2464 mode++;
2465 }
2466 break;
2467
2468 case 'w':
2469 oflags = O_CREAT | O_TRUNC;
2470 if (*++mode == '+') {
2471 oflags |= O_RDWR;
2472 mode++;
2473 }
2474 else
2475 oflags |= O_WRONLY;
2476 break;
2477
2478 case 'a':
2479 oflags = O_CREAT | O_APPEND;
2480 if (*++mode == '+') {
2481 oflags |= O_RDWR;
2482 mode++;
2483 }
2484 else
2485 oflags |= O_WRONLY;
2486 break;
2487 }
2488 if (*mode == 'b') {
2489 oflags |= O_BINARY;
2490 oflags &= ~O_TEXT;
2491 mode++;
2492 }
2493 else if (*mode == 't') {
2494 oflags |= O_TEXT;
2495 oflags &= ~O_BINARY;
2496 mode++;
2497 }
2498 /*
71200d45 2499 * Always open in binary mode
14a5cf38
JH
2500 */
2501 oflags |= O_BINARY;
2502 if (*mode || oflags == -1) {
93189314 2503 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2504 oflags = -1;
2505 }
2506 return oflags;
9e353e3b
NIS
2507}
2508
2509IV
f62ce20a 2510PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2511{
96a5add6 2512 PERL_UNUSED_CONTEXT;
14a5cf38 2513 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS
2514}
2515
aa063c35
NIS
2516static void
2517PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2518{
de009b76 2519 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2520#if defined(WIN32)
aa063c35
NIS
2521 Stat_t st;
2522 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2523 if (!S_ISREG(st.st_mode)) {
aa063c35 2524 PerlIO_debug("%d is not regular file\n",fd);
6caa5a9c
NIS
2525 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2526 }
aa063c35
NIS
2527 else {
2528 PerlIO_debug("%d _is_ a regular file\n",fd);
2529 }
6caa5a9c
NIS
2530 }
2531#endif
aa063c35
NIS
2532 s->fd = fd;
2533 s->oflags = imode;
2534 PerlIOUnix_refcnt_inc(fd);
96a5add6 2535 PERL_UNUSED_CONTEXT;
aa063c35
NIS
2536}
2537
2538IV
2539PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2540{
2541 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2542 if (*PerlIONext(f)) {
4b069b44 2543 /* We never call down so do any pending stuff now */
03c0554d 2544 PerlIO_flush(PerlIONext(f));
14a5cf38 2545 /*
71200d45 2546 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2547 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2548 * Should the value on NULL mode be 0 or -1?
14a5cf38 2549 */
acbd16bf 2550 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2551 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH
2552 }
2553 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2554
14a5cf38 2555 return code;
4b803d04
NIS
2556}
2557
c2fcde81
JH
2558IV
2559PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2560{
de009b76 2561 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2562 Off_t new_loc;
96a5add6 2563 PERL_UNUSED_CONTEXT;
c2fcde81
JH
2564 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2565#ifdef ESPIPE
2566 SETERRNO(ESPIPE, LIB_INVARG);
2567#else
2568 SETERRNO(EINVAL, LIB_INVARG);
2569#endif
2570 return -1;
2571 }
0723351e
NC
2572 new_loc = PerlLIO_lseek(fd, offset, whence);
2573 if (new_loc == (Off_t) - 1)
dcda55fc 2574 return -1;
c2fcde81
JH
2575 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2576 return 0;
2577}
2578
9e353e3b 2579PerlIO *
14a5cf38
JH
2580PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2581 IV n, const char *mode, int fd, int imode,
2582 int perm, PerlIO *f, int narg, SV **args)
2583{
d9dac8cd 2584 if (PerlIOValid(f)) {
14a5cf38 2585 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2586 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH
2587 }
2588 if (narg > 0) {
3b6c1aba 2589 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH
2590 mode++;
2591 else {
2592 imode = PerlIOUnix_oflags(mode);
2593 perm = 0666;
2594 }
2595 if (imode != -1) {
e62f0680 2596 const char *path = SvPV_nolen_const(*args);
14a5cf38
JH
2597 fd = PerlLIO_open3(path, imode, perm);
2598 }
2599 }
2600 if (fd >= 0) {
3b6c1aba 2601 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2602 mode++;
2603 if (!f) {
2604 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS
2605 }
2606 if (!PerlIOValid(f)) {
a33cf58c
NIS
2607 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2608 return NULL;
2609 }
d9dac8cd 2610 }
aa063c35 2611 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2612 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH
2613 if (*mode == IoTYPE_APPEND)
2614 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH
2615 return f;
2616 }
2617 else {
2618 if (f) {
6f207bd3 2619 NOOP;
14a5cf38 2620 /*
71200d45 2621 * FIXME: pop layers ???
14a5cf38
JH
2622 */
2623 }
2624 return NULL;
2625 }
9e353e3b
NIS
2626}
2627
71200d45 2628PerlIO *
ecdeb87c 2629PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2630{
dcda55fc 2631 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2632 int fd = os->fd;
ecdeb87c
NIS
2633 if (flags & PERLIO_DUP_FD) {
2634 fd = PerlLIO_dup(fd);
2635 }
22c96fc1 2636 if (fd >= 0) {
ecdeb87c 2637 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS
2638 if (f) {
2639 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2640 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS
2641 return f;
2642 }
71200d45
NIS
2643 }
2644 return NULL;
2645}
2646
2647
9e353e3b 2648SSize_t
f62ce20a 2649PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2650{
97aff369 2651 dVAR;
de009b76 2652 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2653#ifdef PERLIO_STD_SPECIAL
2654 if (fd == 0)
2655 return PERLIO_STD_IN(fd, vbuf, count);
2656#endif
81428673 2657 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2658 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2659 return 0;
1fd8f4ce 2660 }
14a5cf38 2661 while (1) {
b464bac0 2662 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2663 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2664 if (len < 0) {
2665 if (errno != EAGAIN) {
2666 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2667 }
2668 }
2669 else if (len == 0 && count != 0) {
14a5cf38 2670 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS
2671 SETERRNO(0,0);
2672 }
14a5cf38
JH
2673 return len;
2674 }
2675 PERL_ASYNC_CHECK();
2676 }
b464bac0 2677 /*NOTREACHED*/
9e353e3b
NIS
2678}
2679
2680SSize_t
f62ce20a 2681PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2682{
97aff369 2683 dVAR;
de009b76 2684 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2685#ifdef PERLIO_STD_SPECIAL
2686 if (fd == 1 || fd == 2)
2687 return PERLIO_STD_OUT(fd, vbuf, count);
2688#endif
14a5cf38 2689 while (1) {
de009b76 2690 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2691 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2692 if (len < 0) {
2693 if (errno != EAGAIN) {
2694 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2695 }
2696 }
14a5cf38
JH
2697 return len;
2698 }
2699 PERL_ASYNC_CHECK();
06da4f11 2700 }
1b6737cc 2701 /*NOTREACHED*/
9e353e3b
NIS
2702}
2703
9e353e3b 2704Off_t
f62ce20a 2705PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2706{
96a5add6
AL
2707 PERL_UNUSED_CONTEXT;
2708
14a5cf38 2709 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2710}
2711
71200d45 2712
9e353e3b 2713IV
f62ce20a 2714PerlIOUnix_close(pTHX_ PerlIO *f)
9e353e3b 2715{
97aff369 2716 dVAR;
de009b76 2717 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2718 int code = 0;
168d5872
NIS
2719 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2720 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2721 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2722 return 0;
22569500 2723 }
93a8090d
NIS
2724 }
2725 else {
93189314 2726 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2727 return -1;
2728 }
14a5cf38
JH
2729 while (PerlLIO_close(fd) != 0) {
2730 if (errno != EINTR) {
2731 code = -1;
2732 break;
2733 }
2734 PERL_ASYNC_CHECK();
2735 }
2736 if (code == 0) {
2737 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2738 }
2739 return code;
9e353e3b
NIS
2740}
2741
27da23d5 2742PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2743 sizeof(PerlIO_funcs),
14a5cf38
JH
2744 "unix",
2745 sizeof(PerlIOUnix),
2746 PERLIO_K_RAW,
2747 PerlIOUnix_pushed,
44798d05 2748 PerlIOBase_popped,
14a5cf38 2749 PerlIOUnix_open,
86e05cf2 2750 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2751 NULL,
2752 PerlIOUnix_fileno,
71200d45 2753 PerlIOUnix_dup,
14a5cf38
JH
2754 PerlIOUnix_read,
2755 PerlIOBase_unread,
2756 PerlIOUnix_write,
2757 PerlIOUnix_seek,
2758 PerlIOUnix_tell,
2759 PerlIOUnix_close,
22569500
NIS
2760 PerlIOBase_noop_ok, /* flush */
2761 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2762 PerlIOBase_eof,
2763 PerlIOBase_error,
2764 PerlIOBase_clearerr,
2765 PerlIOBase_setlinebuf,
22569500
NIS
2766 NULL, /* get_base */
2767 NULL, /* get_bufsiz */
2768 NULL, /* get_ptr */
2769 NULL, /* get_cnt */
2770 NULL, /* set_ptrcnt */
9e353e3b
NIS
2771};
2772
2773/*--------------------------------------------------------------------------------------*/
14a5cf38 2774/*
71200d45 2775 * stdio as a layer
14a5cf38 2776 */
9e353e3b 2777
313e59c8
NIS
2778#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2779/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2780 broken by the last second glibc 2.3 fix
2781 */
2782#define STDIO_BUFFER_WRITABLE
2783#endif
2784
2785
14a5cf38
JH
2786typedef struct {
2787 struct _PerlIO base;
22569500 2788 FILE *stdio; /* The stream */
9e353e3b
NIS
2789} PerlIOStdio;
2790
2791IV
f62ce20a 2792PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2793{
96a5add6
AL
2794 PERL_UNUSED_CONTEXT;
2795
c4420975
AL
2796 if (PerlIOValid(f)) {
2797 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2798 if (s)
2799 return PerlSIO_fileno(s);
439ba545
NIS
2800 }
2801 errno = EBADF;
2802 return -1;
9e353e3b
NIS
2803}
2804
766a733e 2805char *
14a5cf38
JH
2806PerlIOStdio_mode(const char *mode, char *tmode)
2807{
de009b76 2808 char * const ret = tmode;
a0625d38
SR
2809 if (mode) {
2810 while (*mode) {
2811 *tmode++ = *mode++;
2812 }
14a5cf38 2813 }
95005ad8 2814#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2815 *tmode++ = 'b';
2816#endif
14a5cf38
JH
2817 *tmode = '\0';
2818 return ret;
2819}
2820
4b803d04 2821IV
2dc2558e 2822PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2823{
1fd8f4ce
NIS
2824 PerlIO *n;
2825 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2826 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS
2827 if (toptab == tab) {
2828 /* Top is already stdio - pop self (duplicate) and use original */
2829 PerlIO_pop(aTHX_ f);
2830 return 0;
2831 } else {
de009b76 2832 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2833 char tmode[8];
2834 FILE *stdio;
81428673 2835 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
2836 mode = PerlIOStdio_mode(mode, tmode)))) {
2837 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2838 /* We never call down so do any pending stuff now */
2839 PerlIO_flush(PerlIONext(f));
81428673 2840 }
1fd8f4ce
NIS
2841 else {
2842 return -1;
2843 }
2844 }
14a5cf38 2845 }
2dc2558e 2846 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
2847}
2848
22569500 2849
9e353e3b 2850PerlIO *
4b069b44 2851PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2852{
14a5cf38
JH
2853 dTHX;
2854 PerlIO *f = NULL;
2855 if (stdio) {
22569500 2856 PerlIOStdio *s;
4b069b44
NIS
2857 if (!mode || !*mode) {
2858 /* We need to probe to see how we can open the stream
2859 so start with read/write and then try write and read
2860 we dup() so that we can fclose without loosing the fd.
2861
2862 Note that the errno value set by a failing fdopen
2863 varies between stdio implementations.
2864 */
de009b76 2865 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 2866 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2867 if (!f2) {
a33cf58c 2868 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
2869 }
2870 if (!f2) {
a33cf58c 2871 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
2872 }
2873 if (!f2) {
2874 /* Don't seem to be able to open */
2875 PerlLIO_close(fd);
2876 return f;
2877 }
2878 fclose(f2);
22569500 2879 }
a0714e2c 2880 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS
2881 s = PerlIOSelf(f, PerlIOStdio);
2882 s->stdio = stdio;
c586124f 2883 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 2884 }
14a5cf38
JH
2885 }
2886 return f;
9e353e3b
NIS
2887}
2888
2889PerlIO *
14a5cf38
JH
2890PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2891 IV n, const char *mode, int fd, int imode,
2892 int perm, PerlIO *f, int narg, SV **args)
2893{
2894 char tmode[8];
d9dac8cd 2895 if (PerlIOValid(f)) {
dcda55fc
AL
2896 const char * const path = SvPV_nolen_const(*args);
2897 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS
2898 FILE *stdio;
2899 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2900 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH
2901 s->stdio);
2902 if (!s->stdio)
2903 return NULL;
2904 s->stdio = stdio;
1751d015 2905 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
2906 return f;
2907 }
2908 else {
2909 if (narg > 0) {
dcda55fc 2910 const char * const path = SvPV_nolen_const(*args);
3b6c1aba 2911 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
2912 mode++;
2913 fd = PerlLIO_open3(path, imode, perm);
2914 }
2915 else {
95005ad8
GH
2916 FILE *stdio;
2917 bool appended = FALSE;
2918#ifdef __CYGWIN__
2919 /* Cygwin wants its 'b' early. */
2920 appended = TRUE;
2921 mode = PerlIOStdio_mode(mode, tmode);
2922#endif
2923 stdio = PerlSIO_fopen(path, mode);
6f0313ac 2924 if (stdio) {
6f0313ac
JH
2925 if (!f) {
2926 f = PerlIO_allocate(aTHX);
2927 }
95005ad8
GH
2928 if (!appended)
2929 mode = PerlIOStdio_mode(mode, tmode);
2930 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2931 if (f) {
0f0f9e2b
JH
2932 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2933 PerlIOUnix_refcnt_inc(fileno(stdio));
2934 } else {
2935 PerlSIO_fclose(stdio);
6f0313ac
JH
2936 }
2937 return f;
2938 }
2939 else {
2940 return NULL;
2941 }
14a5cf38
JH
2942 }
2943 }
2944 if (fd >= 0) {
2945 FILE *stdio = NULL;
2946 int init = 0;
3b6c1aba 2947 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
2948 init = 1;
2949 mode++;
2950 }
2951 if (init) {
2952 switch (fd) {
2953 case 0:
2954 stdio = PerlSIO_stdin;
2955 break;
2956 case 1:
2957 stdio = PerlSIO_stdout;
2958 break;
2959 case 2:
2960 stdio = PerlSIO_stderr;
2961 break;
2962 }
2963 }
2964 else {
2965 stdio = PerlSIO_fdopen(fd, mode =
2966 PerlIOStdio_mode(mode, tmode));
2967 }
2968 if (stdio) {
d9dac8cd
NIS
2969 if (!f) {
2970 f = PerlIO_allocate(aTHX);
2971 }
a33cf58c 2972 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba
JH
2973 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2974 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 2975 }
14a5cf38
JH
2976 return f;
2977 }
2978 }
2979 }
ee518936 2980 return NULL;
9e353e3b
NIS
2981}
2982
1751d015 2983PerlIO *
ecdeb87c 2984PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
2985{
2986 /* This assumes no layers underneath - which is what
2987 happens, but is not how I remember it. NI-S 2001/10/16
2988 */
ecdeb87c 2989 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 2990 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 2991 const int fd = fileno(stdio);
9217ff3f 2992 char mode[8];
ecdeb87c 2993 if (flags & PERLIO_DUP_FD) {
de009b76 2994 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
2995 if (dfd >= 0) {
2996 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
2997 goto set_this;
ecdeb87c
NIS
2998 }
2999 else {
6f207bd3 3000 NOOP;
ecdeb87c
NIS
3001 /* FIXME: To avoid messy error recovery if dup fails
3002 re-use the existing stdio as though flag was not set
3003 */
3004 }
3005 }
9217ff3f
NIS
3006 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3007 set_this:
694c95cf
JH
3008 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3009 PerlIOUnix_refcnt_inc(fileno(stdio));
1751d015
NIS
3010 }
3011 return f;
3012}
3013
0d7a5398
NIS
3014static int
3015PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3016{
96a5add6
AL
3017 PERL_UNUSED_CONTEXT;
3018
0d7a5398 3019 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3020 * PerlIO_set_fileno() support from Configure
0d7a5398 3021 */
ef8eacb8
AT
3022# if defined(__UCLIBC__)
3023 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3024 f->__filedes = -1;
3025 return 1;
3026# elif defined(__GLIBC__)
0d7a5398 3027 /* There may be a better way for GLIBC:
37725cdc 3028 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
3029 */
3030 f->_fileno = -1;
3031 return 1;
3032# elif defined(__sun__)
f5992bc4 3033 PERL_UNUSED_ARG(f);
cfedb851 3034 return 0;
0d7a5398
NIS
3035# elif defined(__hpux)
3036 f->__fileH = 0xff;
3037 f->__fileL = 0xff;
3038 return 1;
9837d373 3039 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3040 your platform does not have special entry try this one.
9837d373
NIS
3041 [For OSF only have confirmation for Tru64 (alpha)
3042 but assume other OSFs will be similar.]
37725cdc 3043 */
9837d373 3044# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
3045 f->_file = -1;
3046 return 1;
3047# elif defined(__FreeBSD__)
3048 /* There may be a better way on FreeBSD:
37725cdc
NIS
3049 - we could insert a dummy func in the _close function entry
3050 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3051 */
3052 f->_file = -1;
0c49ea6a
SU
3053 return 1;
3054# elif defined(__OpenBSD__)
3055 /* There may be a better way on OpenBSD:
3056 - we could insert a dummy func in the _close function entry
3057 f->_close = (int (*)(void *)) dummy_close;
3058 */
3059 f->_file = -1;
0d7a5398 3060 return 1;
59ad941d
IZ
3061# elif defined(__EMX__)
3062 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3063 f->_handle = -1;
3064 return 1;
0d7a5398
NIS
3065# elif defined(__CYGWIN__)
3066 /* There may be a better way on CYGWIN:
37725cdc
NIS
3067 - we could insert a dummy func in the _close function entry
3068 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3069 */
3070 f->_file = -1;
3071 return 1;
3072# elif defined(WIN32)
3073# if defined(__BORLANDC__)
3074 f->fd = PerlLIO_dup(fileno(f));
b475b3e6
JH
3075# elif defined(UNDER_CE)
3076 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3077 structure at all
3078 */
0d7a5398
NIS
3079# else
3080 f->_file = -1;
3081# endif
3082 return 1;
3083# else
3084#if 0
37725cdc 3085 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3086 (which isn't thread safe) instead
37725cdc 3087 */
0d7a5398
NIS
3088# error "Don't know how to set FILE.fileno on your platform"
3089#endif
8772537c 3090 PERL_UNUSED_ARG(f);
0d7a5398
NIS
3091 return 0;
3092# endif
3093}
3094
1751d015 3095IV
f62ce20a 3096PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3097{
c4420975 3098 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
3099 if (!stdio) {
3100 errno = EBADF;
3101 return -1;
3102 }
9217ff3f 3103 else {
de009b76 3104 const int fd = fileno(stdio);
0d7a5398 3105 int invalidate = 0;
bbfd922f 3106 IV result = 0;
0d7a5398
NIS
3107 int saveerr = 0;
3108 int dupfd = 0;
3109#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
3110 /* Socks lib overrides close() but stdio isn't linked to
3111 that library (though we are) - so we must call close()
3112 on sockets on stdio's behalf.
3113 */
0d7a5398
NIS
3114 int optval;
3115 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3116 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3117 invalidate = 1;
0d7a5398 3118#endif
6b4ce6c8 3119 if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
0d7a5398 3120 invalidate = 1;
0d7a5398 3121 if (invalidate) {
6b4ce6c8
AL
3122 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3123 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3124 return 0;
3125 if (stdio == stdout || stdio == stderr)
3126 return PerlIO_flush(f);
37725cdc
NIS
3127 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3128 Use Sarathy's trick from maint-5.6 to invalidate the
3129 fileno slot of the FILE *
3130 */
bbfd922f 3131 result = PerlIO_flush(f);
0d7a5398 3132 saveerr = errno;
6b4ce6c8
AL
3133 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3134 if (!invalidate)
3135 dupfd = PerlLIO_dup(fd);
37725cdc 3136 }
0d7a5398 3137 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3138 /* We treat error from stdio as success if we invalidated
3139 errno may NOT be expected EBADF
e8529473
NIS
3140 */
3141 if (invalidate && result != 0) {
0d7a5398
NIS
3142 errno = saveerr;
3143 result = 0;
37725cdc 3144 }
6b4ce6c8
AL
3145#ifdef SOCKS5_VERSION_NAME
3146 /* in SOCKS' case, let close() determine return value */
3147 result = close(fd);
3148#endif
0d7a5398
NIS
3149 if (dupfd) {
3150 PerlLIO_dup2(dupfd,fd);
8a521f28 3151 PerlLIO_close(dupfd);
9217ff3f
NIS
3152 }
3153 return result;
37725cdc 3154 }
1751d015
NIS
3155}
3156
9e353e3b 3157SSize_t
f62ce20a 3158PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3159{
97aff369 3160 dVAR;
c4420975 3161 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3162 SSize_t got = 0;
4d948241
NIS
3163 for (;;) {
3164 if (count == 1) {
3165 STDCHAR *buf = (STDCHAR *) vbuf;
3166 /*
3167 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3168 * stdio does not do that for fread()
3169 */
de009b76 3170 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3171 if (ch != EOF) {
3172 *buf = ch;
3173 got = 1;
3174 }
14a5cf38 3175 }
4d948241
NIS
3176 else
3177 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3178 if (got == 0 && PerlSIO_ferror(s))
3179 got = -1;
42a7a32f 3180 if (got >= 0 || errno != EINTR)
4d948241
NIS
3181 break;
3182 PERL_ASYNC_CHECK();
42a7a32f 3183 SETERRNO(0,0); /* just in case */
14a5cf38 3184 }
14a5cf38 3185 return got;
9e353e3b
NIS
3186}
3187
3188SSize_t
f62ce20a 3189PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3190{
14a5cf38 3191 SSize_t unread = 0;
c4420975 3192 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3193
313e59c8 3194#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3195 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3196 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3197 STDCHAR *base = PerlIO_get_base(f);
3198 SSize_t cnt = PerlIO_get_cnt(f);
3199 STDCHAR *ptr = PerlIO_get_ptr(f);
3200 SSize_t avail = ptr - base;
3201 if (avail > 0) {
3202 if (avail > count) {
3203 avail = count;
3204 }
3205 ptr -= avail;
3206 Move(buf-avail,ptr,avail,STDCHAR);
3207 count -= avail;
3208 unread += avail;
3209 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3210 if (PerlSIO_feof(s) && unread >= 0)
3211 PerlSIO_clearerr(s);
3212 }
3213 }
313e59c8
NIS
3214 else
3215#endif
3216 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3217 /* We can get pointer to buffer but not its base
3218 Do ungetc() but check chars are ending up in the
3219 buffer
3220 */
3221 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3222 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3223 while (count > 0) {
de009b76 3224 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3225 if (ungetc(ch,s) != ch) {
3226 /* ungetc did not work */
3227 break;
3228 }
3229 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3230 /* Did not change pointer as expected */
3231 fgetc(s); /* get char back again */
3232 break;
3233 }
3234 /* It worked ! */
3235 count--;
3236 unread++;
93679785
NIS
3237 }
3238 }
3239
3240 if (count > 0) {
3241 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3242 }
3243 return unread;
9e353e3b
NIS
3244}
3245
3246SSize_t
f62ce20a 3247PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3248{
97aff369 3249 dVAR;
4d948241
NIS
3250 SSize_t got;
3251 for (;;) {
3252 got = PerlSIO_fwrite(vbuf, 1, count,
3253 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3254 if (got >= 0 || errno != EINTR)
4d948241
NIS
3255 break;
3256 PERL_ASYNC_CHECK();
42a7a32f 3257 SETERRNO(0,0); /* just in case */
4d948241
NIS
3258 }
3259 return got;
9e353e3b
NIS
3260}
3261
94a175e1 3262IV
f62ce20a 3263PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3264{
c4420975 3265 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3266 PERL_UNUSED_CONTEXT;
3267
94a175e1 3268 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3269}
3270
3271Off_t
f62ce20a 3272PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3273{
c4420975 3274 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3275 PERL_UNUSED_CONTEXT;
3276
94a175e1 3277 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3278}
3279
3280IV
f62ce20a 3281PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3282{
c4420975 3283 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3284 PERL_UNUSED_CONTEXT;
3285
14a5cf38
JH
3286 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3287 return PerlSIO_fflush(stdio);
3288 }
3289 else {
6f207bd3 3290 NOOP;
88b61e10 3291#if 0
14a5cf38
JH
3292 /*
3293 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3294 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3295 * design is to do _this_ but not have layer above flush this
71200d45 3296 * layer read-to-read
14a5cf38
JH
3297 */
3298 /*
71200d45 3299 * Not writeable - sync by attempting a seek
14a5cf38 3300 */
79852593 3301 const int err = errno;
14a5cf38
JH
3302 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3303 errno = err;
88b61e10 3304#endif
14a5cf38
JH
3305 }
3306 return 0;
9e353e3b
NIS
3307}
3308
3309IV
f62ce20a 3310PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3311{
96a5add6
AL
3312 PERL_UNUSED_CONTEXT;
3313
14a5cf38 3314 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3315}
3316
3317IV
f62ce20a 3318PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3319{
96a5add6
AL
3320 PERL_UNUSED_CONTEXT;
3321
263df5f1 3322 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3323}
3324
3325void
f62ce20a 3326PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3327{
96a5add6
AL
3328 PERL_UNUSED_CONTEXT;
3329
14a5cf38 3330 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3331}
3332
3333void
f62ce20a 3334PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3335{
96a5add6
AL
3336 PERL_UNUSED_CONTEXT;
3337
9e353e3b 3338#ifdef HAS_SETLINEBUF
14a5cf38 3339 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3340#else
bd61b366 3341 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS
3342#endif
3343}
3344
3345#ifdef FILE_base
3346STDCHAR *
f62ce20a 3347PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3348{
c4420975 3349 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3350 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS
3351}
3352
3353Size_t
f62ce20a 3354PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3355{
c4420975 3356 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3357 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS
3358}
3359#endif
3360
3361#ifdef USE_STDIO_PTR
3362STDCHAR *
f62ce20a 3363PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3364{
c4420975 3365 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3366 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS
3367}
3368
3369SSize_t
f62ce20a 3370PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3371{
c4420975 3372 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3373 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS
3374}
3375
3376void
f62ce20a 3377PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3378{
c4420975 3379 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3380 if (ptr != NULL) {
9e353e3b 3381#ifdef STDIO_PTR_LVALUE
d06fc7d4 3382 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
9e353e3b 3383#ifdef STDIO_PTR_LVAL_SETS_CNT
14a5cf38 3384 if (PerlSIO_get_cnt(stdio) != (cnt)) {
14a5cf38
JH
3385 assert(PerlSIO_get_cnt(stdio) == (cnt));
3386 }
9e353e3b
NIS
3387#endif
3388#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3389 /*
71200d45 3390 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH
3391 */
3392 return;
9e353e3b 3393#endif
22569500 3394#else /* STDIO_PTR_LVALUE */
14a5cf38 3395 PerlProc_abort();
22569500 3396#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH
3397 }
3398 /*
71200d45 3399 * Now (or only) set cnt
14a5cf38 3400 */
9e353e3b 3401#ifdef STDIO_CNT_LVALUE
14a5cf38 3402 PerlSIO_set_cnt(stdio, cnt);
22569500 3403#else /* STDIO_CNT_LVALUE */
9e353e3b 3404#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH
3405 PerlSIO_set_ptr(stdio,
3406 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3407 cnt));
22569500 3408#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3409 PerlProc_abort();
22569500
NIS
3410#endif /* STDIO_PTR_LVAL_SETS_CNT */
3411#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS
3412}
3413
93679785 3414
9e353e3b
NIS
3415#endif
3416
93679785
NIS
3417IV
3418PerlIOStdio_fill(pTHX_ PerlIO *f)
3419{
c4420975 3420 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3421 int c;
96a5add6
AL
3422 PERL_UNUSED_CONTEXT;
3423
93679785
NIS
3424 /*
3425 * fflush()ing read-only streams can cause trouble on some stdio-s
3426 */
3427 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3428 if (PerlSIO_fflush(stdio) != 0)
3429 return EOF;
3430 }
f3be3723
BL
3431 for (;;) {
3432 c = PerlSIO_fgetc(stdio);
3433 if (c != EOF)
3434 break;
3435 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3436 return EOF;
3437 PERL_ASYNC_CHECK();
3438 SETERRNO(0,0);
3439 }
93679785
NIS
3440
3441#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS
3442
3443#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3444 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3445 /* Fake ungetc() to the real buffer in case system's ungetc
3446 goes elsewhere
3447 */
3448 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3449 SSize_t cnt = PerlSIO_get_cnt(stdio);
3450 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3451 if (ptr == base+1) {
3452 *--ptr = (STDCHAR) c;
3453 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3454 if (PerlSIO_feof(stdio))
3455 PerlSIO_clearerr(stdio);
3456 return 0;
3457 }
3458 }
313e59c8
NIS
3459 else
3460#endif
3461 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3462 STDCHAR ch = c;
3463 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3464 return 0;
3465 }
3466 }
93679785
NIS
3467#endif
3468
3469#if defined(VMS)
3470 /* An ungetc()d char is handled separately from the regular
3471 * buffer, so we stuff it in the buffer ourselves.
3472 * Should never get called as should hit code above
3473 */
bad9695d
NIS
3474 *(--((*stdio)->_ptr)) = (unsigned char) c;
3475 (*stdio)->_cnt++;
93679785
NIS
3476#else
3477 /* If buffer snoop scheme above fails fall back to
9f7cd136 3478 using ungetc().
93679785
NIS
3479 */
3480 if (PerlSIO_ungetc(c, stdio) != c)
3481 return EOF;
3482#endif
3483 return 0;
3484}
3485
3486
3487
27da23d5 3488PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3489 sizeof(PerlIO_funcs),
14a5cf38
JH
3490 "stdio",
3491 sizeof(PerlIOStdio),
86e05cf2 3492 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3493 PerlIOStdio_pushed,
44798d05 3494 PerlIOBase_popped,
14a5cf38 3495 PerlIOStdio_open,
86e05cf2 3496 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
3497 NULL,
3498 PerlIOStdio_fileno,
71200d45 3499 PerlIOStdio_dup,
14a5cf38
JH
3500 PerlIOStdio_read,
3501 PerlIOStdio_unread,
3502 PerlIOStdio_write,
3503 PerlIOStdio_seek,
3504 PerlIOStdio_tell,
3505 PerlIOStdio_close,
3506 PerlIOStdio_flush,
3507 PerlIOStdio_fill,
3508 PerlIOStdio_eof,
3509 PerlIOStdio_error,
3510 PerlIOStdio_clearerr,
3511 PerlIOStdio_setlinebuf,
9e353e3b 3512#ifdef FILE_base
14a5cf38
JH
3513 PerlIOStdio_get_base,
3514 PerlIOStdio_get_bufsiz,
9e353e3b 3515#else
14a5cf38
JH
3516 NULL,
3517 NULL,
9e353e3b
NIS
3518#endif
3519#ifdef USE_STDIO_PTR
14a5cf38
JH
3520 PerlIOStdio_get_ptr,
3521 PerlIOStdio_get_cnt,
15b61c98 3522# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
79ed0f43 3523 PerlIOStdio_set_ptrcnt,
15b61c98
JH
3524# else
3525 NULL,
3526# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3527#else
3528 NULL,
14a5cf38
JH
3529 NULL,
3530 NULL,
15b61c98 3531#endif /* USE_STDIO_PTR */
9e353e3b
NIS
3532};
3533
b9d6bf13
JH
3534/* Note that calls to PerlIO_exportFILE() are reversed using
3535 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3536FILE *
81428673 3537PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3538{
e87a358a 3539 dTHX;
81428673
NIS
3540 FILE *stdio = NULL;
3541 if (PerlIOValid(f)) {
3542 char buf[8];
3543 PerlIO_flush(f);
3544 if (!mode || !*mode) {
3545 mode = PerlIO_modestr(f, buf);
3546 }
3547 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3548 if (stdio) {
3549 PerlIOl *l = *f;
9f75cc58 3550 PerlIO *f2;
81428673
NIS
3551 /* De-link any lower layers so new :stdio sticks */
3552 *f = NULL;
a0714e2c 3553 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
9f75cc58 3554 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673 3555 s->stdio = stdio;
6b54a403 3556 PerlIOUnix_refcnt_inc(fileno(stdio));
81428673
NIS
3557 /* Link previous lower layers under new one */
3558 *PerlIONext(f) = l;
3559 }
3560 else {
3561 /* restore layers list */
3562 *f = l;
3563 }
a33cf58c 3564 }
14a5cf38
JH