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