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