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