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