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