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