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