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