This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump several file copyright dates
[perl5.git] / perlio.c
CommitLineData
14a5cf38 1/*
5cb43542
RGS
2 * perlio.c
3 * Copyright (c) 1996-2006, Nick Ing-Simmons
2eee27d7 4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
5cb43542
RGS
5 *
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
760ac839
LW
8 */
9
14a5cf38 10/*
d31a8517
AT
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
4ac71550
TC
13 *
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
d31a8517
AT
15 */
16
166f8a29
DM
17/* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
21 */
22
d31a8517 23/*
71200d45 24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
14a5cf38 25 * at the dispatch tables, even when we do not need it for other reasons.
71200d45 26 * Invent a dSYS macro to abstract this out
14a5cf38 27 */
7bcba3d4
NIS
28#ifdef PERL_IMPLICIT_SYS
29#define dSYS dTHX
30#else
31#define dSYS dNOOP
32#endif
33
760ac839 34#define VOIDUSED 1
12ae5dfc
JH
35#ifdef PERL_MICRO
36# include "uconfig.h"
37#else
b0f06652
VK
38# ifndef USE_CROSS_COMPILE
39# include "config.h"
40# else
41# include "xconfig.h"
42# endif
12ae5dfc 43#endif
760ac839 44
6f9d8c32 45#define PERLIO_NOT_STDIO 0
760ac839 46#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
14a5cf38 47/*
71200d45 48 * #define PerlIO FILE
14a5cf38 49 */
760ac839
LW
50#endif
51/*
6f9d8c32 52 * This file provides those parts of PerlIO abstraction
88b61e10 53 * which are not #defined in perlio.h.
6f9d8c32 54 * Which these are depends on various Configure #ifdef's
760ac839
LW
55 */
56
57#include "EXTERN.h"
864dbfa3 58#define PERL_IN_PERLIO_C
760ac839
LW
59#include "perl.h"
60
32af7c23
CL
61#ifdef PERL_IMPLICIT_CONTEXT
62#undef dSYS
63#define dSYS dTHX
64#endif
65
0c4f7ff0
NIS
66#include "XSUB.h"
67
9cffb111
OS
68#ifdef __Lynx__
69/* Missing proto on LynxOS */
70int mkstemp(char*);
71#endif
72
abf9167d
DM
73#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
74
1b7a0411 75/* Call the callback or PerlIOBase, and return failure. */
b32dd47e 76#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
1b7a0411 77 if (PerlIOValid(f)) { \
46c461b5 78 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
79 if (tab && tab->callback) \
80 return (*tab->callback) args; \
81 else \
82 return PerlIOBase_ ## base args; \
83 } \
84 else \
85 SETERRNO(EBADF, SS_IVCHAN); \
86 return failure
87
88/* Call the callback or fail, and return failure. */
b32dd47e 89#define Perl_PerlIO_or_fail(f, callback, failure, args) \
1b7a0411 90 if (PerlIOValid(f)) { \
46c461b5 91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
92 if (tab && tab->callback) \
93 return (*tab->callback) args; \
94 SETERRNO(EINVAL, LIB_INVARG); \
95 } \
96 else \
97 SETERRNO(EBADF, SS_IVCHAN); \
98 return failure
99
100/* Call the callback or PerlIOBase, and be void. */
b32dd47e 101#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
1b7a0411 102 if (PerlIOValid(f)) { \
46c461b5 103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
106 else \
107 PerlIOBase_ ## base args; \
1b7a0411
JH
108 } \
109 else \
110 SETERRNO(EBADF, SS_IVCHAN)
111
112/* Call the callback or fail, and be void. */
b32dd47e 113#define Perl_PerlIO_or_fail_void(f, callback, args) \
1b7a0411 114 if (PerlIOValid(f)) { \
46c461b5 115 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
116 if (tab && tab->callback) \
117 (*tab->callback) args; \
37725cdc
NIS
118 else \
119 SETERRNO(EINVAL, LIB_INVARG); \
1b7a0411
JH
120 } \
121 else \
122 SETERRNO(EBADF, SS_IVCHAN)
123
89a3a251
JH
124#if defined(__osf__) && _XOPEN_SOURCE < 500
125extern int fseeko(FILE *, off_t, int);
126extern off_t ftello(FILE *);
127#endif
128
71ab4674 129#ifndef USE_SFIO
a0c21aa1
JH
130
131EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
132
71ab4674
SP
133int
134perlsio_binmode(FILE *fp, int iotype, int mode)
135{
136 /*
137 * This used to be contents of do_binmode in doio.c
138 */
139#ifdef DOSISH
cd86ed9d 140# if defined(atarist)
58c0efa5 141 PERL_UNUSED_ARG(iotype);
71ab4674
SP
142 if (!fflush(fp)) {
143 if (mode & O_BINARY)
144 ((FILE *) fp)->_flag |= _IOBIN;
145 else
146 ((FILE *) fp)->_flag &= ~_IOBIN;
147 return 1;
148 }
149 return 0;
150# else
151 dTHX;
58c0efa5 152 PERL_UNUSED_ARG(iotype);
71ab4674
SP
153#ifdef NETWARE
154 if (PerlLIO_setmode(fp, mode) != -1) {
155#else
156 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
157#endif
71ab4674
SP
158 return 1;
159 }
160 else
161 return 0;
162# endif
163#else
164# if defined(USEMYBINMODE)
165 dTHX;
58c0efa5
RGS
166# if defined(__CYGWIN__)
167 PERL_UNUSED_ARG(iotype);
168# endif
71ab4674
SP
169 if (my_binmode(fp, iotype, mode) != FALSE)
170 return 1;
171 else
172 return 0;
173# else
174 PERL_UNUSED_ARG(fp);
175 PERL_UNUSED_ARG(iotype);
176 PERL_UNUSED_ARG(mode);
177 return 1;
178# endif
179#endif
180}
181#endif /* sfio */
182
06c7082d 183#ifndef O_ACCMODE
22569500 184#define O_ACCMODE 3 /* Assume traditional implementation */
06c7082d
NIS
185#endif
186
187int
188PerlIO_intmode2str(int rawmode, char *mode, int *writing)
189{
de009b76 190 const int result = rawmode & O_ACCMODE;
06c7082d
NIS
191 int ix = 0;
192 int ptype;
193 switch (result) {
194 case O_RDONLY:
195 ptype = IoTYPE_RDONLY;
196 break;
197 case O_WRONLY:
198 ptype = IoTYPE_WRONLY;
199 break;
200 case O_RDWR:
201 default:
202 ptype = IoTYPE_RDWR;
203 break;
204 }
205 if (writing)
206 *writing = (result != O_RDONLY);
207
208 if (result == O_RDONLY) {
209 mode[ix++] = 'r';
210 }
211#ifdef O_APPEND
212 else if (rawmode & O_APPEND) {
213 mode[ix++] = 'a';
214 if (result != O_WRONLY)
215 mode[ix++] = '+';
216 }
217#endif
218 else {
219 if (result == O_WRONLY)
220 mode[ix++] = 'w';
221 else {
222 mode[ix++] = 'r';
223 mode[ix++] = '+';
224 }
225 }
226 if (rawmode & O_BINARY)
227 mode[ix++] = 'b';
228 mode[ix] = '\0';
229 return ptype;
230}
231
eb73beca
NIS
232#ifndef PERLIO_LAYERS
233int
234PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
235{
6874a2de
NIS
236 if (!names || !*names
237 || strEQ(names, ":crlf")
238 || strEQ(names, ":raw")
239 || strEQ(names, ":bytes")
240 ) {
14a5cf38
JH
241 return 0;
242 }
243 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
244 /*
71200d45 245 * NOTREACHED
14a5cf38
JH
246 */
247 return -1;
eb73beca
NIS
248}
249
13621cfb
NIS
250void
251PerlIO_destruct(pTHX)
252{
253}
254
f5b9d040
NIS
255int
256PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
257{
92bff44d 258#ifdef USE_SFIO
8772537c
AL
259 PERL_UNUSED_ARG(iotype);
260 PERL_UNUSED_ARG(mode);
261 PERL_UNUSED_ARG(names);
14a5cf38 262 return 1;
92bff44d 263#else
14a5cf38 264 return perlsio_binmode(fp, iotype, mode);
92bff44d 265#endif
f5b9d040 266}
60382766 267
e0fa5af2 268PerlIO *
ecdeb87c 269PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
e0fa5af2 270{
a0fd4948 271#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
0553478e
NIS
272 return NULL;
273#else
274#ifdef PERL_IMPLICIT_SYS
22569500 275 return PerlSIO_fdupopen(f);
0553478e 276#else
30753f56
NIS
277#ifdef WIN32
278 return win32_fdupopen(f);
279#else
e0fa5af2 280 if (f) {
504618e9 281 const int fd = PerlLIO_dup(PerlIO_fileno(f));
e0fa5af2 282 if (fd >= 0) {
06c7082d 283 char mode[8];
a5936e02 284#ifdef DJGPP
dcda55fc
AL
285 const int omode = djgpp_get_stream_mode(f);
286#else
287 const int omode = fcntl(fd, F_GETFL);
a5936e02 288#endif
06c7082d 289 PerlIO_intmode2str(omode,mode,NULL);
e0fa5af2 290 /* the r+ is a hack */
06c7082d 291 return PerlIO_fdopen(fd, mode);
e0fa5af2
NIS
292 }
293 return NULL;
294 }
295 else {
93189314 296 SETERRNO(EBADF, SS_IVCHAN);
e0fa5af2 297 }
7114a2d2 298#endif
e0fa5af2 299 return NULL;
0553478e 300#endif
30753f56 301#endif
e0fa5af2
NIS
302}
303
304
14a5cf38 305/*
71200d45 306 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
14a5cf38 307 */
ee518936
NIS
308
309PerlIO *
14a5cf38
JH
310PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
311 int imode, int perm, PerlIO *old, int narg, SV **args)
312{
7cf31beb
NIS
313 if (narg) {
314 if (narg > 1) {
3b8752bb 315 Perl_croak(aTHX_ "More than one argument to open");
7cf31beb 316 }
14a5cf38
JH
317 if (*args == &PL_sv_undef)
318 return PerlIO_tmpfile();
319 else {
e62f0680 320 const char *name = SvPV_nolen_const(*args);
3b6c1aba 321 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
322 fd = PerlLIO_open3(name, imode, perm);
323 if (fd >= 0)
de009b76 324 return PerlIO_fdopen(fd, mode + 1);
14a5cf38
JH
325 }
326 else if (old) {
327 return PerlIO_reopen(name, mode, old);
328 }
329 else {
330 return PerlIO_open(name, mode);
331 }
332 }
333 }
334 else {
335 return PerlIO_fdopen(fd, (char *) mode);
336 }
337 return NULL;
ee518936
NIS
338}
339
0c4f7ff0
NIS
340XS(XS_PerlIO__Layer__find)
341{
14a5cf38
JH
342 dXSARGS;
343 if (items < 2)
344 Perl_croak(aTHX_ "Usage class->find(name[,load])");
345 else {
dcda55fc 346 const char * const name = SvPV_nolen_const(ST(1));
14a5cf38
JH
347 ST(0) = (strEQ(name, "crlf")
348 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
349 XSRETURN(1);
350 }
0c4f7ff0
NIS
351}
352
353
354void
355Perl_boot_core_PerlIO(pTHX)
356{
14a5cf38 357 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
0c4f7ff0
NIS
358}
359
ac27b0f5
NIS
360#endif
361
32e30700 362
6f9d8c32 363#ifdef PERLIO_IS_STDIO
760ac839
LW
364
365void
e8632036 366PerlIO_init(pTHX)
760ac839 367{
96a5add6 368 PERL_UNUSED_CONTEXT;
14a5cf38
JH
369 /*
370 * Does nothing (yet) except force this file to be included in perl
71200d45 371 * binary. That allows this file to force inclusion of other functions
14a5cf38 372 * that may be required by loadable extensions e.g. for
71200d45 373 * FileHandle::tmpfile
14a5cf38 374 */
760ac839
LW
375}
376
33dcbb9a
PP
377#undef PerlIO_tmpfile
378PerlIO *
8ac85365 379PerlIO_tmpfile(void)
33dcbb9a 380{
14a5cf38 381 return tmpfile();
33dcbb9a
PP
382}
383
22569500 384#else /* PERLIO_IS_STDIO */
760ac839
LW
385
386#ifdef USE_SFIO
387
388#undef HAS_FSETPOS
389#undef HAS_FGETPOS
390
14a5cf38
JH
391/*
392 * This section is just to make sure these functions get pulled in from
71200d45 393 * libsfio.a
14a5cf38 394 */
760ac839
LW
395
396#undef PerlIO_tmpfile
397PerlIO *
c78749f2 398PerlIO_tmpfile(void)
760ac839 399{
14a5cf38 400 return sftmp(0);
760ac839
LW
401}
402
403void
e8632036 404PerlIO_init(pTHX)
760ac839 405{
96a5add6 406 PERL_UNUSED_CONTEXT;
14a5cf38
JH
407 /*
408 * Force this file to be included in perl binary. Which allows this
409 * file to force inclusion of other functions that may be required by
71200d45 410 * loadable extensions e.g. for FileHandle::tmpfile
14a5cf38 411 */
760ac839 412
14a5cf38 413 /*
71200d45 414 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
14a5cf38 415 * results in a lot of lseek()s to regular files and lot of small
71200d45 416 * writes to pipes.
14a5cf38
JH
417 */
418 sfset(sfstdout, SF_SHARE, 0);
760ac839
LW
419}
420
b9d6bf13 421/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
92bff44d 422PerlIO *
4b069b44 423PerlIO_importFILE(FILE *stdio, const char *mode)
92bff44d 424{
de009b76 425 const int fd = fileno(stdio);
4b069b44 426 if (!mode || !*mode) {
81428673 427 mode = "r+";
4b069b44
NIS
428 }
429 return PerlIO_fdopen(fd, mode);
92bff44d
NIS
430}
431
432FILE *
433PerlIO_findFILE(PerlIO *pio)
434{
de009b76
AL
435 const int fd = PerlIO_fileno(pio);
436 FILE * const f = fdopen(fd, "r+");
14a5cf38
JH
437 PerlIO_flush(pio);
438 if (!f && errno == EINVAL)
439 f = fdopen(fd, "w");
440 if (!f && errno == EINVAL)
441 f = fdopen(fd, "r");
442 return f;
92bff44d
NIS
443}
444
445
22569500 446#else /* USE_SFIO */
6f9d8c32 447/*======================================================================================*/
14a5cf38 448/*
71200d45 449 * Implement all the PerlIO interface ourselves.
9e353e3b 450 */
760ac839 451
76ced9ad
NIS
452#include "perliol.h"
453
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 1521 if (!f)
dcbac5bb 1522 /* diag_listed_as: Unknown PerlIO layer "%s" */
a2a5de95 1523 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
75208dda
RGS
1524 return f;
1525 }
14a5cf38
JH
1526
1527 /*
71200d45 1528 * For other types allow if layer is known but don't try and load it
14a5cf38
JH
1529 */
1530 switch (SvTYPE(sv)) {
1531 case SVt_PVAV:
6a245ed1 1532 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
14a5cf38 1533 case SVt_PVHV:
6a245ed1 1534 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
14a5cf38 1535 case SVt_PVCV:
6a245ed1 1536 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
14a5cf38 1537 case SVt_PVGV:
6a245ed1 1538 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
42d0e0b7
AL
1539 default:
1540 return NULL;
14a5cf38 1541 }
2edd7e44
NIS
1542}
1543
fcf2db38 1544PerlIO_list_t *
14a5cf38
JH
1545PerlIO_resolve_layers(pTHX_ const char *layers,
1546 const char *mode, int narg, SV **args)
1547{
97aff369 1548 dVAR;
14a5cf38
JH
1549 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1550 int incdef = 1;
a1ea730d 1551 if (!PL_perlio)
14a5cf38
JH
1552 PerlIO_stdstreams(aTHX);
1553 if (narg) {
dcda55fc 1554 SV * const arg = *args;
14a5cf38 1555 /*
71200d45
NIS
1556 * If it is a reference but not an object see if we have a handler
1557 * for it
14a5cf38
JH
1558 */
1559 if (SvROK(arg) && !sv_isobject(arg)) {
46c461b5 1560 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1561 if (handler) {
3a1ee7e8
NIS
1562 def = PerlIO_list_alloc(aTHX);
1563 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH
1564 incdef = 0;
1565 }
1566 /*
e934609f 1567 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1568 * something sensible else we will just stringfy and open
71200d45 1569 * resulting string.
14a5cf38
JH
1570 */
1571 }
1572 }
9fe371da 1573 if (!layers || !*layers)
11bcd5da 1574 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1575 if (layers && *layers) {
1576 PerlIO_list_t *av;
1577 if (incdef) {
a951d81d 1578 av = PerlIO_clone_list(aTHX_ def, NULL);
14a5cf38
JH
1579 }
1580 else {
1581 av = def;
1582 }
0cff2cf3
NIS
1583 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1584 return av;
1585 }
1586 else {
1587 PerlIO_list_free(aTHX_ av);
b37c2d43 1588 return NULL;
0cff2cf3 1589 }
14a5cf38
JH
1590 }
1591 else {
1592 if (incdef)
1593 def->refcnt++;
1594 return def;
1595 }
ee518936
NIS
1596}
1597
1598PerlIO *
14a5cf38
JH
1599PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1600 int imode, int perm, PerlIO *f, int narg, SV **args)
1601{
97aff369 1602 dVAR;
14a5cf38
JH
1603 if (!f && narg == 1 && *args == &PL_sv_undef) {
1604 if ((f = PerlIO_tmpfile())) {
9fe371da 1605 if (!layers || !*layers)
11bcd5da 1606 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1607 if (layers && *layers)
1608 PerlIO_apply_layers(aTHX_ f, mode, layers);
1609 }
1610 }
1611 else {
de009b76 1612 PerlIO_list_t *layera;
14a5cf38
JH
1613 IV n;
1614 PerlIO_funcs *tab = NULL;
04892f78 1615 if (PerlIOValid(f)) {
14a5cf38 1616 /*
71200d45
NIS
1617 * This is "reopen" - it is not tested as perl does not use it
1618 * yet
14a5cf38
JH
1619 */
1620 PerlIOl *l = *f;
3a1ee7e8 1621 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1622 while (l) {
a951d81d 1623 SV *arg = NULL;
cc6623a8 1624 if (l->tab && l->tab->Getarg)
a951d81d
BL
1625 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1626 PerlIO_list_push(aTHX_ layera, l->tab,
1627 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1628 SvREFCNT_dec(arg);
14a5cf38
JH
1629 l = *PerlIONext(&l);
1630 }
1631 }
1632 else {
1633 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS
1634 if (!layera) {
1635 return NULL;
1636 }
14a5cf38
JH
1637 }
1638 /*
71200d45 1639 * Start at "top" of layer stack
14a5cf38
JH
1640 */
1641 n = layera->cur - 1;
1642 while (n >= 0) {
46c461b5 1643 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH
1644 if (t && t->Open) {
1645 tab = t;
1646 break;
1647 }
1648 n--;
1649 }
1650 if (tab) {
1651 /*
71200d45 1652 * Found that layer 'n' can do opens - call it
14a5cf38 1653 */
7cf31beb 1654 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1655 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1656 }
14a5cf38 1657 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
355d3743
PD
1658 tab->name, layers ? layers : "(Null)", mode, fd,
1659 imode, perm, (void*)f, narg, (void*)args);
210e727c
JH
1660 if (tab->Open)
1661 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1662 f, narg, args);
1663 else {
1664 SETERRNO(EINVAL, LIB_INVARG);
1665 f = NULL;
1666 }
14a5cf38
JH
1667 if (f) {
1668 if (n + 1 < layera->cur) {
1669 /*
1670 * More layers above the one that we used to open -
71200d45 1671 * apply them now
14a5cf38 1672 */
d9dac8cd
NIS
1673 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1674 /* If pushing layers fails close the file */
1675 PerlIO_close(f);
14a5cf38
JH
1676 f = NULL;
1677 }
1678 }
1679 }
1680 }
3a1ee7e8 1681 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH
1682 }
1683 return f;
ee518936 1684}
b931b1d9
NIS
1685
1686
9e353e3b 1687SSize_t
e87a358a 1688Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1689{
7918f24d
NC
1690 PERL_ARGS_ASSERT_PERLIO_READ;
1691
b32dd47e 1692 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1693}
1694
313ca112 1695SSize_t
e87a358a 1696Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1697{
7918f24d
NC
1698 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1699
b32dd47e 1700 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1701}
1702
9e353e3b 1703SSize_t
e87a358a 1704Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1705{
7918f24d
NC
1706 PERL_ARGS_ASSERT_PERLIO_WRITE;
1707
b32dd47e 1708 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1709}
1710
6f9d8c32 1711int
e87a358a 1712Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1713{
b32dd47e 1714 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW
1715}
1716
9e353e3b 1717Off_t
e87a358a 1718Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1719{
b32dd47e 1720 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW
1721}
1722
6f9d8c32 1723int
e87a358a 1724Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1725{
97aff369 1726 dVAR;
14a5cf38
JH
1727 if (f) {
1728 if (*f) {
de009b76 1729 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH
1730
1731 if (tab && tab->Flush)
f62ce20a 1732 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH
1733 else
1734 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH
1735 }
1736 else {
fe5a182c 1737 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
93189314 1738 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1739 return -1;
1740 }
1741 }
1742 else {
1743 /*
1744 * Is it good API design to do flush-all on NULL, a potentially
486ec47a 1745 * erroneous input? Maybe some magical value (PerlIO*
14a5cf38
JH
1746 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1747 * things on fflush(NULL), but should we be bound by their design
71200d45 1748 * decisions? --jhi
14a5cf38 1749 */
303f2dc3
DM
1750 PerlIOl **table = &PL_perlio;
1751 PerlIOl *ff;
14a5cf38 1752 int code = 0;
303f2dc3 1753 while ((ff = *table)) {
14a5cf38 1754 int i;
303f2dc3 1755 table = (PerlIOl **) (ff++);
14a5cf38 1756 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 1757 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
14a5cf38 1758 code = -1;
303f2dc3 1759 ff++;
14a5cf38
JH
1760 }
1761 }
1762 return code;
1763 }
760ac839
LW
1764}
1765
a9c883f6 1766void
f62ce20a 1767PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1768{
97aff369 1769 dVAR;
303f2dc3
DM
1770 PerlIOl **table = &PL_perlio;
1771 PerlIOl *f;
14a5cf38
JH
1772 while ((f = *table)) {
1773 int i;
303f2dc3 1774 table = (PerlIOl **) (f++);
14a5cf38 1775 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM
1776 if (f->next
1777 && (PerlIOBase(&(f->next))->
14a5cf38
JH
1778 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1779 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
303f2dc3 1780 PerlIO_flush(&(f->next));
14a5cf38
JH
1781 f++;
1782 }
a9c883f6 1783 }
a9c883f6
NIS
1784}
1785
06da4f11 1786int
e87a358a 1787Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1788{
b32dd47e 1789 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS
1790}
1791
f3862f8b
NIS
1792int
1793PerlIO_isutf8(PerlIO *f)
1794{
1b7a0411
JH
1795 if (PerlIOValid(f))
1796 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1797 else
1798 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1799
1b7a0411 1800 return -1;
f3862f8b
NIS
1801}
1802
6f9d8c32 1803int
e87a358a 1804Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1805{
b32dd47e 1806 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS
1807}
1808
9e353e3b 1809int
e87a358a 1810Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1811{
b32dd47e 1812 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS
1813}
1814
9e353e3b 1815void
e87a358a 1816Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1817{
b32dd47e 1818 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS
1819}
1820
9e353e3b 1821void
e87a358a 1822Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1823{
b32dd47e 1824 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS
1825}
1826
9e353e3b
NIS
1827int
1828PerlIO_has_base(PerlIO *f)
1829{
1b7a0411 1830 if (PerlIOValid(f)) {
46c461b5 1831 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1832
1833 if (tab)
1834 return (tab->Get_base != NULL);
1b7a0411 1835 }
1b7a0411
JH
1836
1837 return 0;
760ac839
LW
1838}
1839
9e353e3b
NIS
1840int
1841PerlIO_fast_gets(PerlIO *f)
760ac839 1842{
d7dfc388
SK
1843 if (PerlIOValid(f)) {
1844 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1845 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411 1846
d7dfc388
SK
1847 if (tab)
1848 return (tab->Set_ptrcnt != NULL);
d7dfc388 1849 }
14a5cf38 1850 }
1b7a0411 1851
14a5cf38 1852 return 0;
9e353e3b
NIS
1853}
1854
9e353e3b
NIS
1855int
1856PerlIO_has_cntptr(PerlIO *f)
1857{
04892f78 1858 if (PerlIOValid(f)) {
46c461b5 1859 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1860
1861 if (tab)
1862 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
14a5cf38 1863 }
1b7a0411 1864
14a5cf38 1865 return 0;
9e353e3b
NIS
1866}
1867
9e353e3b
NIS
1868int
1869PerlIO_canset_cnt(PerlIO *f)
1870{
04892f78 1871 if (PerlIOValid(f)) {
46c461b5 1872 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1873
1874 if (tab)
1875 return (tab->Set_ptrcnt != NULL);
14a5cf38 1876 }
1b7a0411 1877
14a5cf38 1878 return 0;
760ac839
LW
1879}
1880
888911fc 1881STDCHAR *
e87a358a 1882Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1883{
b32dd47e 1884 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS
1885}
1886
9e353e3b 1887int
e87a358a 1888Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1889{
b32dd47e 1890 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS
1891}
1892
9e353e3b 1893STDCHAR *
e87a358a 1894Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1895{
b32dd47e 1896 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS
1897}
1898
05d1247b 1899int
e87a358a 1900Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1901{
b32dd47e 1902 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS
1903}
1904
9e353e3b 1905void
e87a358a 1906Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
9e353e3b 1907{
b32dd47e 1908 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS
1909}
1910
9e353e3b 1911void
e87a358a 1912Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
9e353e3b 1913{
b32dd47e 1914 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS
1915}
1916
4ec2216f 1917
9e353e3b 1918/*--------------------------------------------------------------------------------------*/
14a5cf38 1919/*
71200d45 1920 * utf8 and raw dummy layers
14a5cf38 1921 */
dfebf958 1922
26fb694e 1923IV
2dc2558e 1924PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1925{
96a5add6 1926 PERL_UNUSED_CONTEXT;
8772537c
AL
1927 PERL_UNUSED_ARG(mode);
1928 PERL_UNUSED_ARG(arg);
00f51856 1929 if (PerlIOValid(f)) {
cc6623a8 1930 if (tab && tab->kind & PERLIO_K_UTF8)
14a5cf38
JH
1931 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1932 else
1933 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1934 return 0;
1935 }
1936 return -1;
26fb694e
NIS
1937}
1938
27da23d5 1939PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1940 sizeof(PerlIO_funcs),
14a5cf38 1941 "utf8",
2dc2558e 1942 0,
a778d1f5 1943 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
14a5cf38
JH
1944 PerlIOUtf8_pushed,
1945 NULL,
c0888ace 1946 PerlIOBase_open,
14a5cf38
JH
1947 NULL,
1948 NULL,
1949 NULL,
1950 NULL,
1951 NULL,
1952 NULL,
1953 NULL,
1954 NULL,
de009b76
AL
1955 NULL,
1956 NULL,
22569500
NIS
1957 NULL, /* flush */
1958 NULL, /* fill */
14a5cf38
JH
1959 NULL,
1960 NULL,
1961 NULL,
1962 NULL,
22569500
NIS
1963 NULL, /* get_base */
1964 NULL, /* get_bufsiz */
1965 NULL, /* get_ptr */
1966 NULL, /* get_cnt */
1967 NULL, /* set_ptrcnt */
26fb694e
NIS
1968};
1969
27da23d5 1970PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1971 sizeof(PerlIO_funcs),
14a5cf38 1972 "bytes",
2dc2558e 1973 0,
a778d1f5 1974 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
14a5cf38
JH
1975 PerlIOUtf8_pushed,
1976 NULL,
c0888ace 1977 PerlIOBase_open,
14a5cf38
JH
1978 NULL,
1979 NULL,
1980 NULL,
1981 NULL,
1982 NULL,
1983 NULL,
1984 NULL,
1985 NULL,
de009b76
AL
1986 NULL,
1987 NULL,
22569500
NIS
1988 NULL, /* flush */
1989 NULL, /* fill */
14a5cf38
JH
1990 NULL,
1991 NULL,
1992 NULL,
1993 NULL,
22569500
NIS
1994 NULL, /* get_base */
1995 NULL, /* get_bufsiz */
1996 NULL, /* get_ptr */
1997 NULL, /* get_cnt */
1998 NULL, /* set_ptrcnt */
dfebf958
NIS
1999};
2000
27da23d5 2001PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 2002 sizeof(PerlIO_funcs),
14a5cf38 2003 "raw",
2dc2558e 2004 0,
14a5cf38
JH
2005 PERLIO_K_DUMMY,
2006 PerlIORaw_pushed,
2007 PerlIOBase_popped,
ecfd0649 2008 PerlIOBase_open,
14a5cf38
JH
2009 NULL,
2010 NULL,
2011 NULL,
2012 NULL,
2013 NULL,
2014 NULL,
2015 NULL,
2016 NULL,
de009b76
AL
2017 NULL,
2018 NULL,
22569500
NIS
2019 NULL, /* flush */
2020 NULL, /* fill */
14a5cf38
JH
2021 NULL,
2022 NULL,
2023 NULL,
2024 NULL,
22569500
NIS
2025 NULL, /* get_base */
2026 NULL, /* get_bufsiz */
2027 NULL, /* get_ptr */
2028 NULL, /* get_cnt */
2029 NULL, /* set_ptrcnt */
dfebf958
NIS
2030};
2031/*--------------------------------------------------------------------------------------*/
2032/*--------------------------------------------------------------------------------------*/
14a5cf38 2033/*
71200d45 2034 * "Methods" of the "base class"
14a5cf38 2035 */
9e353e3b
NIS
2036
2037IV
f62ce20a 2038PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 2039{
04892f78 2040 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS
2041}
2042
f5b9d040 2043char *
81428673 2044PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH
2045{
2046 char *s = buf;
81428673 2047 if (PerlIOValid(f)) {
de009b76 2048 const IV flags = PerlIOBase(f)->flags;
81428673
NIS
2049 if (flags & PERLIO_F_APPEND) {
2050 *s++ = 'a';
2051 if (flags & PERLIO_F_CANREAD) {
2052 *s++ = '+';
2053 }
14a5cf38 2054 }
81428673
NIS
2055 else if (flags & PERLIO_F_CANREAD) {
2056 *s++ = 'r';
2057 if (flags & PERLIO_F_CANWRITE)
2058 *s++ = '+';
2059 }
2060 else if (flags & PERLIO_F_CANWRITE) {
2061 *s++ = 'w';
2062 if (flags & PERLIO_F_CANREAD) {
2063 *s++ = '+';
2064 }
14a5cf38 2065 }
35990314 2066#ifdef PERLIO_USING_CRLF
81428673
NIS
2067 if (!(flags & PERLIO_F_CRLF))
2068 *s++ = 'b';
5f1a76d0 2069#endif
81428673 2070 }
14a5cf38
JH
2071 *s = '\0';
2072 return buf;
f5b9d040
NIS
2073}
2074
81428673 2075
76ced9ad 2076IV
2dc2558e 2077PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 2078{
de009b76 2079 PerlIOl * const l = PerlIOBase(f);
96a5add6 2080 PERL_UNUSED_CONTEXT;
8772537c 2081 PERL_UNUSED_ARG(arg);
de009b76 2082
14a5cf38
JH
2083 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2084 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
cc6623a8 2085 if (tab && tab->Set_ptrcnt != NULL)
14a5cf38
JH
2086 l->flags |= PERLIO_F_FASTGETS;
2087 if (mode) {
3b6c1aba 2088 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2089 mode++;
2090 switch (*mode++) {
2091 case 'r':
2092 l->flags |= PERLIO_F_CANREAD;
2093 break;
2094 case 'a':
2095 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2096 break;
2097 case 'w':
2098 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2099 break;
2100 default:
93189314 2101 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2102 return -1;
2103 }
2104 while (*mode) {
2105 switch (*mode++) {
2106 case '+':
2107 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2108 break;
2109 case 'b':
2110 l->flags &= ~PERLIO_F_CRLF;
2111 break;
2112 case 't':
2113 l->flags |= PERLIO_F_CRLF;
2114 break;
2115 default:
93189314 2116 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2117 return -1;
2118 }
2119 }
2120 }
2121 else {
2122 if (l->next) {
2123 l->flags |= l->next->flags &
2124 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2125 PERLIO_F_APPEND);
2126 }
2127 }
5e2ab84b 2128#if 0
14a5cf38 2129 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
6c9570dc 2130 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
14a5cf38 2131 l->flags, PerlIO_modestr(f, temp));
5e2ab84b 2132#endif
14a5cf38 2133 return 0;
76ced9ad
NIS
2134}
2135
2136IV
f62ce20a 2137PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2138{
96a5add6 2139 PERL_UNUSED_CONTEXT;
8772537c 2140 PERL_UNUSED_ARG(f);
14a5cf38 2141 return 0;
760ac839
LW
2142}
2143
9e353e3b 2144SSize_t
f62ce20a 2145PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2146{
14a5cf38 2147 /*
71200d45 2148 * Save the position as current head considers it
14a5cf38 2149 */
de009b76 2150 const Off_t old = PerlIO_tell(f);
a0714e2c 2151 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2152 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2153 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS
2154}
2155
f6c77cf1 2156SSize_t
f62ce20a 2157PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2158{
14a5cf38
JH
2159 STDCHAR *buf = (STDCHAR *) vbuf;
2160 if (f) {
263df5f1
JH
2161 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2162 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2163 SETERRNO(EBADF, SS_IVCHAN);
2164 return 0;
2165 }
14a5cf38 2166 while (count > 0) {
93c2c2ec
IZ
2167 get_cnt:
2168 {
14a5cf38
JH
2169 SSize_t avail = PerlIO_get_cnt(f);
2170 SSize_t take = 0;
2171 if (avail > 0)
bb7a0f54 2172 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
14a5cf38
JH
2173 if (take > 0) {
2174 STDCHAR *ptr = PerlIO_get_ptr(f);
2175 Copy(ptr, buf, take, STDCHAR);
2176 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2177 count -= take;
2178 buf += take;
93c2c2ec
IZ
2179 if (avail == 0) /* set_ptrcnt could have reset avail */
2180 goto get_cnt;
14a5cf38
JH
2181 }
2182 if (count > 0 && avail <= 0) {
2183 if (PerlIO_fill(f) != 0)
2184 break;
2185 }
93c2c2ec 2186 }
14a5cf38
JH
2187 }
2188 return (buf - (STDCHAR *) vbuf);
2189 }
f6c77cf1 2190 return 0;
f6c77cf1
NIS
2191}
2192
9e353e3b 2193IV
f62ce20a 2194PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2195{
96a5add6 2196 PERL_UNUSED_CONTEXT;
8772537c 2197 PERL_UNUSED_ARG(f);
14a5cf38 2198 return 0;
9e353e3b
NIS
2199}
2200
2201IV
f62ce20a 2202PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2203{
96a5add6 2204 PERL_UNUSED_CONTEXT;
8772537c 2205 PERL_UNUSED_ARG(f);
14a5cf38 2206 return -1;
06da4f11
NIS
2207}
2208
2209IV
f62ce20a 2210PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2211{
37725cdc
NIS
2212 IV code = -1;
2213 if (PerlIOValid(f)) {
2214 PerlIO *n = PerlIONext(f);
2215 code = PerlIO_flush(f);
2216 PerlIOBase(f)->flags &=
2217 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2218 while (PerlIOValid(n)) {
de009b76 2219 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS
2220 if (tab && tab->Close) {
2221 if ((*tab->Close)(aTHX_ n) != 0)
2222 code = -1;
2223 break;
2224 }
2225 else {
2226 PerlIOBase(n)->flags &=
2227 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2228 }
2229 n = PerlIONext(n);
2230 }
2231 }
2232 else {
2233 SETERRNO(EBADF, SS_IVCHAN);
2234 }
14a5cf38 2235 return code;
9e353e3b
NIS
2236}
2237
2238IV
f62ce20a 2239PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2240{
96a5add6 2241 PERL_UNUSED_CONTEXT;
04892f78 2242 if (PerlIOValid(f)) {
14a5cf38
JH
2243 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2244 }
2245 return 1;
9e353e3b
NIS
2246}
2247
2248IV
f62ce20a 2249PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2250{
96a5add6 2251 PERL_UNUSED_CONTEXT;
04892f78 2252 if (PerlIOValid(f)) {
14a5cf38
JH
2253 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2254 }
2255 return 1;
9e353e3b
NIS
2256}
2257
2258void
f62ce20a 2259PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2260{
04892f78 2261 if (PerlIOValid(f)) {
dcda55fc 2262 PerlIO * const n = PerlIONext(f);
14a5cf38 2263 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2264 if (PerlIOValid(n))
14a5cf38
JH
2265 PerlIO_clearerr(n);
2266 }
9e353e3b
NIS
2267}
2268
2269void
f62ce20a 2270PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2271{
96a5add6 2272 PERL_UNUSED_CONTEXT;
04892f78 2273 if (PerlIOValid(f)) {
14a5cf38
JH
2274 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2275 }
9e353e3b
NIS
2276}
2277
93a8090d
NIS
2278SV *
2279PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2280{
2281 if (!arg)
a0714e2c 2282 return NULL;
93a8090d
NIS
2283#ifdef sv_dup
2284 if (param) {
a951d81d
BL
2285 arg = sv_dup(arg, param);
2286 SvREFCNT_inc_simple_void_NN(arg);
2287 return arg;
93a8090d
NIS
2288 }
2289 else {
2290 return newSVsv(arg);
2291 }
2292#else
1b6737cc 2293 PERL_UNUSED_ARG(param);
93a8090d
NIS
2294 return newSVsv(arg);
2295#endif
2296}
2297
2298PerlIO *
ecdeb87c 2299PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2300{
1b6737cc 2301 PerlIO * const nexto = PerlIONext(o);
04892f78 2302 if (PerlIOValid(nexto)) {
de009b76 2303 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS
2304 if (tab && tab->Dup)
2305 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2306 else
2307 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS
2308 }
2309 if (f) {
dcda55fc 2310 PerlIO_funcs * const self = PerlIOBase(o)->tab;
a951d81d 2311 SV *arg = NULL;
93a8090d 2312 char buf[8];
fe5a182c 2313 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
cc6623a8
DM
2314 self ? self->name : "(Null)",
2315 (void*)f, (void*)o, (void*)param);
2316 if (self && self->Getarg)
210e727c 2317 arg = (*self->Getarg)(aTHX_ o, param, flags);
93a8090d 2318 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
f0720f70
RGS
2319 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2320 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
ef8d46e8 2321 SvREFCNT_dec(arg);
93a8090d
NIS
2322 }
2323 return f;
2324}
2325
27da23d5 2326/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d 2327
8b84d7dd 2328/* Must be called with PL_perlio_mutex locked. */
22c96fc1
NC
2329static void
2330S_more_refcounted_fds(pTHX_ const int new_fd) {
7a89be66 2331 dVAR;
22c96fc1 2332 const int old_max = PL_perlio_fd_refcnt_size;
f4ae5be6 2333 const int new_max = 16 + (new_fd & ~15);
22c96fc1
NC
2334 int *new_array;
2335
2336 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2337 old_max, new_fd, new_max);
2338
2339 if (new_fd < old_max) {
2340 return;
2341 }
2342
f4ae5be6
NC
2343 assert (new_max > new_fd);
2344
eae082a0
JH
2345 /* Use plain realloc() since we need this memory to be really
2346 * global and visible to all the interpreters and/or threads. */
2347 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
22c96fc1
NC
2348
2349 if (!new_array) {
8b84d7dd 2350#ifdef USE_ITHREADS
6cb8cb21 2351 MUTEX_UNLOCK(&PL_perlio_mutex);
22c96fc1
NC
2352#endif
2353 /* Can't use PerlIO to write as it allocates memory */
2354 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2355 PL_no_mem, strlen(PL_no_mem));
2356 my_exit(1);
2357 }
2358
2359 PL_perlio_fd_refcnt_size = new_max;
2360 PL_perlio_fd_refcnt = new_array;
2361
95b63a38
JH
2362 PerlIO_debug("Zeroing %p, %d\n",
2363 (void*)(new_array + old_max),
2364 new_max - old_max);
22c96fc1
NC
2365
2366 Zero(new_array + old_max, new_max - old_max, int);
2367}
2368
2369
93a8090d
NIS
2370void
2371PerlIO_init(pTHX)
2372{
8b84d7dd 2373 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
96a5add6 2374 PERL_UNUSED_CONTEXT;
93a8090d
NIS
2375}
2376
168d5872
NIS
2377void
2378PerlIOUnix_refcnt_inc(int fd)
2379{
27da23d5 2380 dTHX;
22c96fc1 2381 if (fd >= 0) {
97aff369 2382 dVAR;
22c96fc1 2383
8b84d7dd 2384#ifdef USE_ITHREADS
6cb8cb21 2385 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2386#endif
22c96fc1
NC
2387 if (fd >= PL_perlio_fd_refcnt_size)
2388 S_more_refcounted_fds(aTHX_ fd);
2389
27da23d5 2390 PL_perlio_fd_refcnt[fd]++;
8b84d7dd 2391 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2392 /* diag_listed_as: refcnt_inc: fd %d%s */
8b84d7dd
RGS
2393 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2394 fd, PL_perlio_fd_refcnt[fd]);
2395 }
2396 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2397 fd, PL_perlio_fd_refcnt[fd]);
22c96fc1 2398
8b84d7dd 2399#ifdef USE_ITHREADS
6cb8cb21 2400 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2401#endif
8b84d7dd 2402 } else {
12605ff9 2403 /* diag_listed_as: refcnt_inc: fd %d%s */
8b84d7dd 2404 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
168d5872
NIS
2405 }
2406}
2407
168d5872
NIS
2408int
2409PerlIOUnix_refcnt_dec(int fd)
2410{
27da23d5 2411 dTHX;
168d5872 2412 int cnt = 0;
22c96fc1 2413 if (fd >= 0) {
97aff369 2414 dVAR;
8b84d7dd 2415#ifdef USE_ITHREADS
6cb8cb21 2416 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2417#endif
8b84d7dd 2418 if (fd >= PL_perlio_fd_refcnt_size) {
12605ff9 2419 /* diag_listed_as: refcnt_dec: fd %d%s */
8b84d7dd
RGS
2420 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2421 fd, PL_perlio_fd_refcnt_size);
2422 }
2423 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2424 /* diag_listed_as: refcnt_dec: fd %d%s */
8b84d7dd
RGS
2425 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2426 fd, PL_perlio_fd_refcnt[fd]);
2427 }
27da23d5 2428 cnt = --PL_perlio_fd_refcnt[fd];
8b84d7dd
RGS
2429 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2430#ifdef USE_ITHREADS
6cb8cb21 2431 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2432#endif
8b84d7dd 2433 } else {
12605ff9 2434 /* diag_listed_as: refcnt_dec: fd %d%s */
8b84d7dd 2435 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
168d5872
NIS
2436 }
2437 return cnt;
2438}
2439
2e0cfa16
FC
2440int
2441PerlIOUnix_refcnt(int fd)
2442{
2443 dTHX;
2444 int cnt = 0;
2445 if (fd >= 0) {
2446 dVAR;
2447#ifdef USE_ITHREADS
2448 MUTEX_LOCK(&PL_perlio_mutex);
2449#endif
2450 if (fd >= PL_perlio_fd_refcnt_size) {
2451 /* diag_listed_as: refcnt: fd %d%s */
2452 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2453 fd, PL_perlio_fd_refcnt_size);
2454 }
2455 if (PL_perlio_fd_refcnt[fd] <= 0) {
2456 /* diag_listed_as: refcnt: fd %d%s */
2457 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2458 fd, PL_perlio_fd_refcnt[fd]);
2459 }
2460 cnt = PL_perlio_fd_refcnt[fd];
2461#ifdef USE_ITHREADS
2462 MUTEX_UNLOCK(&PL_perlio_mutex);
2463#endif
2464 } else {
2465 /* diag_listed_as: refcnt: fd %d%s */
2466 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2467 }
2468 return cnt;
2469}
2470
694c95cf
JH
2471void
2472PerlIO_cleanup(pTHX)
2473{
97aff369 2474 dVAR;
694c95cf
JH
2475 int i;
2476#ifdef USE_ITHREADS
a25429c6 2477 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
9f4bd222
NIS
2478#else
2479 PerlIO_debug("Cleanup layers\n");
694c95cf 2480#endif
e47547a8 2481
694c95cf
JH
2482 /* Raise STDIN..STDERR refcount so we don't close them */
2483 for (i=0; i < 3; i++)
2484 PerlIOUnix_refcnt_inc(i);
2485 PerlIO_cleantable(aTHX_ &PL_perlio);
2486 /* Restore STDIN..STDERR refcount */
2487 for (i=0; i < 3; i++)
2488 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS
2489
2490 if (PL_known_layers) {
2491 PerlIO_list_free(aTHX_ PL_known_layers);
2492 PL_known_layers = NULL;
2493 }
27da23d5 2494 if (PL_def_layerlist) {
9f4bd222
NIS
2495 PerlIO_list_free(aTHX_ PL_def_layerlist);
2496 PL_def_layerlist = NULL;
2497 }
6cb8cb21
RGS
2498}
2499
0934c9d9 2500void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
6cb8cb21 2501{
53d44271 2502 dVAR;
4f3da17a
DM
2503#if 0
2504/* XXX we can't rely on an interpreter being present at this late stage,
2505 XXX so we can't use a function like PerlLIO_write that relies on one
2506 being present (at least in win32) :-(.
2507 Disable for now.
2508*/
6cb8cb21
RGS
2509#ifdef DEBUGGING
2510 {
2511 /* By now all filehandles should have been closed, so any
2512 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2513 * errors. */
77db880c
JH
2514#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2515#define PERLIO_TEARDOWN_MESSAGE_FD 2
2516 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
6cb8cb21
RGS
2517 int i;
2518 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
77db880c
JH
2519 if (PL_perlio_fd_refcnt[i]) {
2520 const STRLEN len =
2521 my_snprintf(buf, sizeof(buf),
2522 "PerlIO_teardown: fd %d refcnt=%d\n",
2523 i, PL_perlio_fd_refcnt[i]);
2524 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2525 }
6cb8cb21
RGS
2526 }
2527 }
2528#endif
4f3da17a 2529#endif
eae082a0
JH
2530 /* Not bothering with PL_perlio_mutex since by now
2531 * all the interpreters are gone. */
1cd82952
RGS
2532 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2533 && PL_perlio_fd_refcnt) {
eae082a0 2534 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO
2535 PL_perlio_fd_refcnt = NULL;
2536 PL_perlio_fd_refcnt_size = 0;
1cd82952 2537 }
694c95cf
JH
2538}
2539
9e353e3b 2540/*--------------------------------------------------------------------------------------*/
14a5cf38 2541/*
71200d45 2542 * Bottom-most level for UNIX-like case
14a5cf38 2543 */
9e353e3b 2544
14a5cf38 2545typedef struct {
22569500
NIS
2546 struct _PerlIO base; /* The generic part */
2547 int fd; /* UNIX like file descriptor */
2548 int oflags; /* open/fcntl flags */
9e353e3b
NIS
2549} PerlIOUnix;
2550
abf9167d
DM
2551static void
2552S_lockcnt_dec(pTHX_ const void* f)
2553{
2554 PerlIO_lockcnt((PerlIO*)f)--;
2555}
2556
2557
2558/* call the signal handler, and if that handler happens to clear
2559 * this handle, free what we can and return true */
2560
2561static bool
2562S_perlio_async_run(pTHX_ PerlIO* f) {
2563 ENTER;
2564 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2565 PerlIO_lockcnt(f)++;
2566 PERL_ASYNC_CHECK();
be48bbe8
CS
2567 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2568 LEAVE;
abf9167d 2569 return 0;
be48bbe8 2570 }
abf9167d
DM
2571 /* we've just run some perl-level code that could have done
2572 * anything, including closing the file or clearing this layer.
2573 * If so, free any lower layers that have already been
2574 * cleared, then return an error. */
2575 while (PerlIOValid(f) &&
2576 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2577 {
2578 const PerlIOl *l = *f;
2579 *f = l->next;
2580 Safefree(l);
2581 }
be48bbe8 2582 LEAVE;
abf9167d
DM
2583 return 1;
2584}
2585
6f9d8c32 2586int
9e353e3b 2587PerlIOUnix_oflags(const char *mode)
760ac839 2588{
14a5cf38 2589 int oflags = -1;
3b6c1aba 2590 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH
2591 mode++;
2592 switch (*mode) {
2593 case 'r':
2594 oflags = O_RDONLY;
2595 if (*++mode == '+') {
2596 oflags = O_RDWR;
2597 mode++;
2598 }
2599 break;
2600
2601 case 'w':
2602 oflags = O_CREAT | O_TRUNC;
2603 if (*++mode == '+') {
2604 oflags |= O_RDWR;
2605 mode++;
2606 }
2607 else
2608 oflags |= O_WRONLY;
2609 break;
2610
2611 case 'a':
2612 oflags = O_CREAT | O_APPEND;
2613 if (*++mode == '+') {
2614 oflags |= O_RDWR;
2615 mode++;
2616 }
2617 else
2618 oflags |= O_WRONLY;
2619 break;
2620 }
2621 if (*mode == 'b') {
2622 oflags |= O_BINARY;
2623 oflags &= ~O_TEXT;
2624 mode++;
2625 }
2626 else if (*mode == 't') {
2627 oflags |= O_TEXT;
2628 oflags &= ~O_BINARY;
2629 mode++;
2630 }
2631 /*
71200d45 2632 * Always open in binary mode
14a5cf38
JH
2633 */
2634 oflags |= O_BINARY;
2635 if (*mode || oflags == -1) {
93189314 2636 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2637 oflags = -1;
2638 }
2639 return oflags;
9e353e3b
NIS
2640}
2641
2642IV
f62ce20a 2643PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2644{
96a5add6 2645 PERL_UNUSED_CONTEXT;
14a5cf38 2646 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS
2647}
2648
aa063c35
NIS
2649static void
2650PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2651{
de009b76 2652 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2653#if defined(WIN32)
aa063c35
NIS
2654 Stat_t st;
2655 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2656 if (!S_ISREG(st.st_mode)) {
aa063c35 2657 PerlIO_debug("%d is not regular file\n",fd);
6caa5a9c
NIS
2658 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2659 }
aa063c35
NIS
2660 else {
2661 PerlIO_debug("%d _is_ a regular file\n",fd);
2662 }
6caa5a9c
NIS
2663 }
2664#endif
aa063c35
NIS
2665 s->fd = fd;
2666 s->oflags = imode;
2667 PerlIOUnix_refcnt_inc(fd);
96a5add6 2668 PERL_UNUSED_CONTEXT;
aa063c35
NIS
2669}
2670
2671IV
2672PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2673{
2674 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2675 if (*PerlIONext(f)) {
4b069b44 2676 /* We never call down so do any pending stuff now */
03c0554d 2677 PerlIO_flush(PerlIONext(f));
14a5cf38 2678 /*
71200d45 2679 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2680 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2681 * Should the value on NULL mode be 0 or -1?
14a5cf38 2682 */
acbd16bf 2683 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2684 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH
2685 }
2686 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2687
14a5cf38 2688 return code;
4b803d04
NIS
2689}
2690
c2fcde81
JH
2691IV
2692PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2693{
de009b76 2694 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2695 Off_t new_loc;
96a5add6 2696 PERL_UNUSED_CONTEXT;
c2fcde81
JH
2697 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2698#ifdef ESPIPE
2699 SETERRNO(ESPIPE, LIB_INVARG);
2700#else
2701 SETERRNO(EINVAL, LIB_INVARG);
2702#endif
2703 return -1;
2704 }
0723351e
NC
2705 new_loc = PerlLIO_lseek(fd, offset, whence);
2706 if (new_loc == (Off_t) - 1)
dcda55fc 2707 return -1;
c2fcde81
JH
2708 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2709 return 0;
2710}
2711
9e353e3b 2712PerlIO *
14a5cf38
JH
2713PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2714 IV n, const char *mode, int fd, int imode,
2715 int perm, PerlIO *f, int narg, SV **args)
2716{
d9dac8cd 2717 if (PerlIOValid(f)) {
cc6623a8 2718 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2719 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH
2720 }
2721 if (narg > 0) {
3b6c1aba 2722 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH
2723 mode++;
2724 else {
2725 imode = PerlIOUnix_oflags(mode);
5e2ce0f3
CB
2726#ifdef VMS
2727 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2728#else
14a5cf38 2729 perm = 0666;
5e2ce0f3 2730#endif
14a5cf38
JH
2731 }
2732 if (imode != -1) {
e62f0680 2733 const char *path = SvPV_nolen_const(*args);
14a5cf38
JH
2734 fd = PerlLIO_open3(path, imode, perm);
2735 }
2736 }
2737 if (fd >= 0) {
3b6c1aba 2738 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2739 mode++;
2740 if (!f) {
2741 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS
2742 }
2743 if (!PerlIOValid(f)) {
a33cf58c
NIS
2744 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2745 return NULL;
2746 }
d9dac8cd 2747 }
aa063c35 2748 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2749 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH
2750 if (*mode == IoTYPE_APPEND)
2751 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH
2752 return f;
2753 }
2754 else {
2755 if (f) {
6f207bd3 2756 NOOP;
14a5cf38 2757 /*
71200d45 2758 * FIXME: pop layers ???
14a5cf38
JH
2759 */
2760 }
2761 return NULL;
2762 }
9e353e3b
NIS
2763}
2764
71200d45 2765PerlIO *
ecdeb87c 2766PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2767{
dcda55fc 2768 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2769 int fd = os->fd;
ecdeb87c
NIS
2770 if (flags & PERLIO_DUP_FD) {
2771 fd = PerlLIO_dup(fd);
2772 }
22c96fc1 2773 if (fd >= 0) {
ecdeb87c 2774 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS
2775 if (f) {
2776 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2777 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS
2778 return f;
2779 }
71200d45
NIS
2780 }
2781 return NULL;
2782}
2783
2784
9e353e3b 2785SSize_t
f62ce20a 2786PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2787{
97aff369 2788 dVAR;
abf9167d
DM
2789 int fd;
2790 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2791 return -1;
2792 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2793#ifdef PERLIO_STD_SPECIAL
2794 if (fd == 0)
2795 return PERLIO_STD_IN(fd, vbuf, count);
2796#endif
81428673 2797 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2798 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2799 return 0;
1fd8f4ce 2800 }
14a5cf38 2801 while (1) {
b464bac0 2802 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2803 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2804 if (len < 0) {
2805 if (errno != EAGAIN) {
2806 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2807 }
2808 }
2809 else if (len == 0 && count != 0) {
14a5cf38 2810 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS
2811 SETERRNO(0,0);
2812 }
14a5cf38
JH
2813 return len;
2814 }
abf9167d
DM
2815 /* EINTR */
2816 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2817 return -1;
14a5cf38 2818 }
b464bac0 2819 /*NOTREACHED*/
9e353e3b
NIS
2820}
2821
2822SSize_t
f62ce20a 2823PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2824{
97aff369 2825 dVAR;
abf9167d
DM
2826 int fd;
2827 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2828 return -1;
2829 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2830#ifdef PERLIO_STD_SPECIAL
2831 if (fd == 1 || fd == 2)
2832 return PERLIO_STD_OUT(fd, vbuf, count);
2833#endif
14a5cf38 2834 while (1) {
de009b76 2835 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2836 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2837 if (len < 0) {
2838 if (errno != EAGAIN) {
2839 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2840 }
2841 }
14a5cf38
JH
2842 return len;
2843 }
abf9167d
DM
2844 /* EINTR */
2845 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2846 return -1;
06da4f11 2847 }
1b6737cc 2848 /*NOTREACHED*/
9e353e3b
NIS
2849}
2850
9e353e3b 2851Off_t
f62ce20a 2852PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2853{
96a5add6
AL
2854 PERL_UNUSED_CONTEXT;
2855
14a5cf38 2856 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2857}
2858
2556f95e
GF
2859
2860IV
2376d97d 2861PerlIOUnix_close(pTHX_ PerlIO *f)
2556f95e 2862{
97aff369 2863 dVAR;
de009b76 2864 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2865 int code = 0;
168d5872
NIS
2866 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2867 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2868 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2869 return 0;
22569500 2870 }
93a8090d
NIS
2871 }
2872 else {
93189314 2873 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2874 return -1;
2875 }
14a5cf38
JH
2876 while (PerlLIO_close(fd) != 0) {
2877 if (errno != EINTR) {
2878 code = -1;
2879 break;
2880 }
abf9167d
DM
2881 /* EINTR */
2882 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2883 return -1;
14a5cf38
JH
2884 }
2885 if (code == 0) {
2886 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2887 }
2888 return code;
9e353e3b
NIS
2889}
2890
27da23d5 2891PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2892 sizeof(PerlIO_funcs),
14a5cf38
JH
2893 "unix",
2894 sizeof(PerlIOUnix),
2895 PERLIO_K_RAW,
2896 PerlIOUnix_pushed,
2376d97d 2897 PerlIOBase_popped,
14a5cf38 2898 PerlIOUnix_open,
86e05cf2 2899 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2900 NULL,
2901 PerlIOUnix_fileno,
71200d45 2902 PerlIOUnix_dup,
14a5cf38
JH
2903 PerlIOUnix_read,
2904 PerlIOBase_unread,
2905 PerlIOUnix_write,
2906 PerlIOUnix_seek,
2907 PerlIOUnix_tell,
2908 PerlIOUnix_close,
22569500
NIS
2909 PerlIOBase_noop_ok, /* flush */
2910 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2911 PerlIOBase_eof,
2912 PerlIOBase_error,
2913 PerlIOBase_clearerr,
2914 PerlIOBase_setlinebuf,
22569500
NIS
2915 NULL, /* get_base */
2916 NULL, /* get_bufsiz */
2917 NULL, /* get_ptr */
2918 NULL, /* get_cnt */
2919 NULL, /* set_ptrcnt */
9e353e3b
NIS
2920};
2921
2922/*--------------------------------------------------------------------------------------*/
14a5cf38 2923/*
71200d45 2924 * stdio as a layer
14a5cf38 2925 */
9e353e3b 2926
313e59c8
NIS
2927#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2928/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2929 broken by the last second glibc 2.3 fix
2930 */
2931#define STDIO_BUFFER_WRITABLE
2932#endif
2933
2934
14a5cf38
JH
2935typedef struct {
2936 struct _PerlIO base;
22569500 2937 FILE *stdio; /* The stream */
9e353e3b
NIS
2938} PerlIOStdio;
2939
2940IV
f62ce20a 2941PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2942{
96a5add6
AL
2943 PERL_UNUSED_CONTEXT;
2944
c4420975
AL
2945 if (PerlIOValid(f)) {
2946 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2947 if (s)
2948 return PerlSIO_fileno(s);
439ba545
NIS
2949 }
2950 errno = EBADF;
2951 return -1;
9e353e3b
NIS
2952}
2953
766a733e 2954char *
14a5cf38
JH
2955PerlIOStdio_mode(const char *mode, char *tmode)
2956{
de009b76 2957 char * const ret = tmode;
a0625d38
SR
2958 if (mode) {
2959 while (*mode) {
2960 *tmode++ = *mode++;
2961 }
14a5cf38 2962 }
95005ad8 2963#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2964 *tmode++ = 'b';
2965#endif
14a5cf38
JH
2966 *tmode = '\0';
2967 return ret;
2968}
2969
4b803d04 2970IV
2dc2558e 2971PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2972{
1fd8f4ce
NIS
2973 PerlIO *n;
2974 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2975 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS
2976 if (toptab == tab) {
2977 /* Top is already stdio - pop self (duplicate) and use original */
2978 PerlIO_pop(aTHX_ f);
2979 return 0;
2980 } else {
de009b76 2981 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2982 char tmode[8];
2983 FILE *stdio;
81428673 2984 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
2985 mode = PerlIOStdio_mode(mode, tmode)))) {
2986 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2987 /* We never call down so do any pending stuff now */
2988 PerlIO_flush(PerlIONext(f));
81428673 2989 }
1fd8f4ce
NIS
2990 else {
2991 return -1;
2992 }
2993 }
14a5cf38 2994 }
2dc2558e 2995 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
2996}
2997
22569500 2998
9e353e3b 2999PerlIO *
4b069b44 3000PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 3001{
14a5cf38
JH
3002 dTHX;
3003 PerlIO *f = NULL;
3004 if (stdio) {
22569500 3005 PerlIOStdio *s;
4b069b44
NIS
3006 if (!mode || !*mode) {
3007 /* We need to probe to see how we can open the stream
3008 so start with read/write and then try write and read
3009 we dup() so that we can fclose without loosing the fd.
3010
3011 Note that the errno value set by a failing fdopen
3012 varies between stdio implementations.
3013 */
de009b76 3014 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 3015 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 3016 if (!f2) {
a33cf58c 3017 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
3018 }
3019 if (!f2) {
a33cf58c 3020 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
3021 }
3022 if (!f2) {
3023 /* Don't seem to be able to open */
3024 PerlLIO_close(fd);
3025 return f;
3026 }
3027 fclose(f2);
22569500 3028 }
a0714e2c 3029 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS
3030 s = PerlIOSelf(f, PerlIOStdio);
3031 s->stdio = stdio;
c586124f 3032 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 3033 }
14a5cf38
JH
3034 }
3035 return f;
9e353e3b
NIS
3036}
3037
3038PerlIO *
14a5cf38
JH
3039PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3040 IV n, const char *mode, int fd, int imode,
3041 int perm, PerlIO *f, int narg, SV **args)
3042{
3043 char tmode[8];
d9dac8cd 3044 if (PerlIOValid(f)) {
dcda55fc
AL
3045 const char * const path = SvPV_nolen_const(*args);
3046 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS
3047 FILE *stdio;
3048 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3049 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH
3050 s->stdio);
3051 if (!s->stdio)
3052 return NULL;
3053 s->stdio = stdio;
1751d015 3054 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
3055 return f;
3056 }
3057 else {
3058 if (narg > 0) {
dcda55fc 3059 const char * const path = SvPV_nolen_const(*args);
3b6c1aba 3060 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
3061 mode++;
3062 fd = PerlLIO_open3(path, imode, perm);
3063 }
3064 else {
95005ad8
GH
3065 FILE *stdio;
3066 bool appended = FALSE;
3067#ifdef __CYGWIN__
3068 /* Cygwin wants its 'b' early. */
3069 appended = TRUE;
3070 mode = PerlIOStdio_mode(mode, tmode);
3071#endif
3072 stdio = PerlSIO_fopen(path, mode);
6f0313ac 3073 if (stdio) {
6f0313ac
JH
3074 if (!f) {
3075 f = PerlIO_allocate(aTHX);
3076 }
95005ad8
GH
3077 if (!appended)
3078 mode = PerlIOStdio_mode(mode, tmode);
3079 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3080 if (f) {
0f0f9e2b
JH
3081 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3082 PerlIOUnix_refcnt_inc(fileno(stdio));
3083 } else {
3084 PerlSIO_fclose(stdio);
6f0313ac
JH
3085 }
3086 return f;
3087 }
3088 else {
3089 return NULL;
3090 }
14a5cf38
JH
3091 }
3092 }
3093 if (fd >= 0) {
3094 FILE *stdio = NULL;
3095 int init = 0;
3b6c1aba 3096 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
3097 init = 1;
3098 mode++;
3099 }
3100 if (init) {
3101 switch (fd) {
3102 case 0:
3103 stdio = PerlSIO_stdin;
3104 break;
3105 case 1:
3106 stdio = PerlSIO_stdout;
3107 break;
3108 case 2:
3109 stdio = PerlSIO_stderr;
3110 break;
3111 }
3112 }
3113 else {
3114 stdio = PerlSIO_fdopen(fd, mode =
3115 PerlIOStdio_mode(mode, tmode));
3116 }
3117 if (stdio) {
d9dac8cd
NIS
3118 if (!f) {
3119 f = PerlIO_allocate(aTHX);
3120 }
a33cf58c 3121 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba
JH
3122 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3123 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 3124 }
14a5cf38
JH
3125 return f;
3126 }
3127 }
3128 }
ee518936 3129 return NULL;
9e353e3b
NIS
3130}
3131
1751d015 3132PerlIO *
ecdeb87c 3133PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
3134{
3135 /* This assumes no layers underneath - which is what
3136 happens, but is not how I remember it. NI-S 2001/10/16
3137 */
ecdeb87c 3138 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 3139 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 3140 const int fd = fileno(stdio);
9217ff3f 3141 char mode[8];
ecdeb87c 3142 if (flags & PERLIO_DUP_FD) {
de009b76 3143 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
3144 if (dfd >= 0) {
3145 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3146 goto set_this;
ecdeb87c
NIS
3147 }
3148 else {
6f207bd3 3149 NOOP;
ecdeb87c
NIS
3150 /* FIXME: To avoid messy error recovery if dup fails
3151 re-use the existing stdio as though flag was not set
3152 */
3153 }
3154 }
9217ff3f
NIS
3155 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3156 set_this:
694c95cf 3157 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
40596bc5
SP
3158 if(stdio) {
3159 PerlIOUnix_refcnt_inc(fileno(stdio));
3160 }
1751d015
NIS
3161 }
3162 return f;
3163}
3164
0d7a5398
NIS
3165static int
3166PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3167{
96a5add6
AL
3168 PERL_UNUSED_CONTEXT;
3169
0d7a5398 3170 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3171 * PerlIO_set_fileno() support from Configure
0d7a5398 3172 */
ef8eacb8
AT
3173# if defined(__UCLIBC__)
3174 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3175 f->__filedes = -1;
3176 return 1;
3177# elif defined(__GLIBC__)
0d7a5398 3178 /* There may be a better way for GLIBC:
37725cdc 3179 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
3180 */
3181 f->_fileno = -1;
3182 return 1;
3183# elif defined(__sun__)
f5992bc4 3184 PERL_UNUSED_ARG(f);
cfedb851 3185 return 0;
0d7a5398
NIS
3186# elif defined(__hpux)
3187 f->__fileH = 0xff;
3188 f->__fileL = 0xff;
3189 return 1;
9837d373 3190 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3191 your platform does not have special entry try this one.
9837d373
NIS
3192 [For OSF only have confirmation for Tru64 (alpha)
3193 but assume other OSFs will be similar.]
37725cdc 3194 */
9837d373 3195# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
3196 f->_file = -1;
3197 return 1;
3198# elif defined(__FreeBSD__)
3199 /* There may be a better way on FreeBSD:
37725cdc
NIS
3200 - we could insert a dummy func in the _close function entry
3201 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3202 */
3203 f->_file = -1;
0c49ea6a
SU
3204 return 1;
3205# elif defined(__OpenBSD__)
3206 /* There may be a better way on OpenBSD:
3207 - we could insert a dummy func in the _close function entry
3208 f->_close = (int (*)(void *)) dummy_close;
3209 */
3210 f->_file = -1;
0d7a5398 3211 return 1;
59ad941d
IZ
3212# elif defined(__EMX__)
3213 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3214 f->_handle = -1;
3215 return 1;
0d7a5398
NIS
3216# elif defined(__CYGWIN__)
3217 /* There may be a better way on CYGWIN:
37725cdc
NIS
3218 - we could insert a dummy func in the _close function entry
3219 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3220 */
3221 f->_file = -1;
3222 return 1;
3223# elif defined(WIN32)
378eeda7 3224# if defined(UNDER_CE)
b475b3e6
JH
3225 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3226 structure at all
3227 */
0d7a5398
NIS
3228# else
3229 f->_file = -1;
3230# endif
3231 return 1;
3232# else
3233#if 0
37725cdc 3234 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3235 (which isn't thread safe) instead
37725cdc 3236 */
0d7a5398
NIS
3237# error "Don't know how to set FILE.fileno on your platform"
3238#endif
8772537c 3239 PERL_UNUSED_ARG(f);
0d7a5398
NIS
3240 return 0;
3241# endif
3242}
3243
1751d015 3244IV
f62ce20a 3245PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3246{
c4420975 3247 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
3248 if (!stdio) {
3249 errno = EBADF;
3250 return -1;
3251 }
9217ff3f 3252 else {
de009b76 3253 const int fd = fileno(stdio);
0d7a5398 3254 int invalidate = 0;
bbfd922f 3255 IV result = 0;
1d791a44 3256 int dupfd = -1;
4ee39169 3257 dSAVEDERRNO;
a2e578da
MHM
3258#ifdef USE_ITHREADS
3259 dVAR;
3260#endif
0d7a5398 3261#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
3262 /* Socks lib overrides close() but stdio isn't linked to
3263 that library (though we are) - so we must call close()
3264 on sockets on stdio's behalf.
3265 */
0d7a5398
NIS
3266 int optval;
3267 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3268 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3269 invalidate = 1;
0d7a5398 3270#endif
d8723f43
NC
3271 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3272 that a subsequent fileno() on it returns -1. Don't want to croak()
3273 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3274 trying to close an already closed handle which somehow it still has
3275 a reference to. (via.xs, I'm looking at you). */
3276 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3277 /* File descriptor still in use */
0d7a5398 3278 invalidate = 1;
d8723f43 3279 }
0d7a5398 3280 if (invalidate) {
6b4ce6c8
AL
3281 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3282 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3283 return 0;
3284 if (stdio == stdout || stdio == stderr)
3285 return PerlIO_flush(f);
37725cdc
NIS
3286 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3287 Use Sarathy's trick from maint-5.6 to invalidate the
3288 fileno slot of the FILE *
3289 */
bbfd922f 3290 result = PerlIO_flush(f);
4ee39169 3291 SAVE_ERRNO;
6b4ce6c8 3292 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
711e8db2 3293 if (!invalidate) {
9bab90c0
NC
3294#ifdef USE_ITHREADS
3295 MUTEX_LOCK(&PL_perlio_mutex);
5ca745d2
NC
3296 /* Right. We need a mutex here because for a brief while we
3297 will have the situation that fd is actually closed. Hence if
3298 a second thread were to get into this block, its dup() would
3299 likely return our fd as its dupfd. (after all, it is closed)
9bab90c0
NC
3300 Then if we get to the dup2() first, we blat the fd back
3301 (messing up its temporary as a side effect) only for it to
3302 then close its dupfd (== our fd) in its close(dupfd) */
3303
3304 /* There is, of course, a race condition, that any other thread
3305 trying to input/output/whatever on this fd will be stuffed
5ca745d2
NC
3306 for the duration of this little manoeuvrer. Perhaps we
3307 should hold an IO mutex for the duration of every IO
3308 operation if we know that invalidate doesn't work on this
3309 platform, but that would suck, and could kill performance.
9bab90c0
NC
3310
3311 Except that correctness trumps speed.
3312 Advice from klortho #11912. */
3313#endif
6b4ce6c8 3314 dupfd = PerlLIO_dup(fd);
711e8db2 3315#ifdef USE_ITHREADS
9bab90c0
NC
3316 if (dupfd < 0) {
3317 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2
NC
3318 /* Oh cXap. This isn't going to go well. Not sure if we can
3319 recover from here, or if closing this particular FILE *
3320 is a good idea now. */
3321 }
3322#endif
3323 }
94ccb807
JH
3324 } else {
3325 SAVE_ERRNO; /* This is here only to silence compiler warnings */
37725cdc 3326 }
0d7a5398 3327 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3328 /* We treat error from stdio as success if we invalidated
3329 errno may NOT be expected EBADF
e8529473
NIS
3330 */
3331 if (invalidate && result != 0) {
4ee39169 3332 RESTORE_ERRNO;
0d7a5398 3333 result = 0;
37725cdc 3334 }
6b4ce6c8
AL
3335#ifdef SOCKS5_VERSION_NAME
3336 /* in SOCKS' case, let close() determine return value */
3337 result = close(fd);
3338#endif
1d791a44 3339 if (dupfd >= 0) {
0d7a5398 3340 PerlLIO_dup2(dupfd,fd);
9bab90c0 3341 PerlLIO_close(dupfd);
711e8db2 3342#ifdef USE_ITHREADS
9bab90c0 3343 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2 3344#endif
9217ff3f
NIS
3345 }
3346 return result;
37725cdc 3347 }
1751d015
NIS
3348}
3349
9e353e3b 3350SSize_t
f62ce20a 3351PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3352{
97aff369 3353 dVAR;
abf9167d 3354 FILE * s;
14a5cf38 3355 SSize_t got = 0;
abf9167d
DM
3356 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3357 return -1;
3358 s = PerlIOSelf(f, PerlIOStdio)->stdio;
4d948241
NIS
3359 for (;;) {
3360 if (count == 1) {
3361 STDCHAR *buf = (STDCHAR *) vbuf;
3362 /*
3363 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3364 * stdio does not do that for fread()
3365 */
de009b76 3366 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3367 if (ch != EOF) {
3368 *buf = ch;
3369 got = 1;
3370 }
14a5cf38 3371 }
4d948241
NIS
3372 else
3373 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3374 if (got == 0 && PerlSIO_ferror(s))
3375 got = -1;
42a7a32f 3376 if (got >= 0 || errno != EINTR)
4d948241 3377 break;
abf9167d
DM
3378 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3379 return -1;
42a7a32f 3380 SETERRNO(0,0); /* just in case */
14a5cf38 3381 }
14a5cf38 3382 return got;
9e353e3b
NIS
3383}
3384
3385SSize_t
f62ce20a 3386PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3387{
14a5cf38 3388 SSize_t unread = 0;
c4420975 3389 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3390
313e59c8 3391#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3392 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3393 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3394 STDCHAR *base = PerlIO_get_base(f);
3395 SSize_t cnt = PerlIO_get_cnt(f);
3396 STDCHAR *ptr = PerlIO_get_ptr(f);
3397 SSize_t avail = ptr - base;
3398 if (avail > 0) {
3399 if (avail > count) {
3400 avail = count;
3401 }
3402 ptr -= avail;
3403 Move(buf-avail,ptr,avail,STDCHAR);
3404 count -= avail;
3405 unread += avail;
3406 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3407 if (PerlSIO_feof(s) && unread >= 0)
3408 PerlSIO_clearerr(s);
3409 }
3410 }
313e59c8
NIS
3411 else
3412#endif
3413 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3414 /* We can get pointer to buffer but not its base
3415 Do ungetc() but check chars are ending up in the
3416 buffer
3417 */
3418 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3419 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3420 while (count > 0) {
de009b76 3421 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3422 if (ungetc(ch,s) != ch) {
3423 /* ungetc did not work */
3424 break;
3425 }
3426 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3427 /* Did not change pointer as expected */
3428 fgetc(s); /* get char back again */
3429 break;
3430 }
3431 /* It worked ! */
3432 count--;
3433 unread++;
93679785
NIS
3434 }
3435 }
3436
3437 if (count > 0) {
3438 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3439 }
3440 return unread;
9e353e3b
NIS
3441}
3442
3443SSize_t
f62ce20a 3444PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3445{
97aff369 3446 dVAR;
4d948241 3447 SSize_t got;
abf9167d
DM
3448 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3449 return -1;
4d948241
NIS
3450 for (;;) {
3451 got = PerlSIO_fwrite(vbuf, 1, count,
3452 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3453 if (got >= 0 || errno != EINTR)
4d948241 3454 break;
abf9167d
DM
3455 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3456 return -1;
42a7a32f 3457 SETERRNO(0,0); /* just in case */
4d948241
NIS
3458 }
3459 return got;
9e353e3b
NIS
3460}
3461
94a175e1 3462IV
f62ce20a 3463PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3464{
c4420975 3465 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3466 PERL_UNUSED_CONTEXT;
3467
94a175e1 3468 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3469}
3470
3471Off_t
f62ce20a 3472PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3473{
c4420975 3474 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3475 PERL_UNUSED_CONTEXT;
3476
94a175e1 3477 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3478}
3479
3480IV
f62ce20a 3481PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3482{
c4420975 3483 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3484 PERL_UNUSED_CONTEXT;
3485
14a5cf38
JH
3486 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3487 return PerlSIO_fflush(stdio);
3488 }
3489 else {
6f207bd3 3490 NOOP;
88b61e10 3491#if 0
14a5cf38
JH
3492 /*
3493 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3494 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3495 * design is to do _this_ but not have layer above flush this
71200d45 3496 * layer read-to-read
14a5cf38
JH
3497 */
3498 /*
71200d45 3499 * Not writeable - sync by attempting a seek
14a5cf38 3500 */
4ee39169 3501 dSAVE_ERRNO;
14a5cf38 3502 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3503 RESTORE_ERRNO;
88b61e10 3504#endif
14a5cf38
JH
3505 }
3506 return 0;
9e353e3b
NIS
3507}
3508
3509IV
f62ce20a 3510PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3511{
96a5add6
AL
3512 PERL_UNUSED_CONTEXT;
3513
14a5cf38 3514 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3515}
3516
3517IV
f62ce20a 3518PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3519{
96a5add6
AL
3520 PERL_UNUSED_CONTEXT;
3521
263df5f1 3522 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3523}