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