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