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