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